!The Polymorphic Tracking Code
!Copyright (C) Etienne Forest and CERN

MODULE S_DEF_KIND
  USE S_def_all_kinds   ! not needed because of things below
  public
  PRIVATE DRIFTP  !,DRIFT   ! ,DRIFTR
  PRIVATE SPARR,SPARP !,SPAR
  PRIVATE CAVITYR,CAVITYP !,CAVITY
  PRIVATE CAVER,CAVEP
  PRIVATE KICKCAVR,KICKCAVP !,KICKCAV
  PRIVATE FRINGECAVR,FRINGECAVP   !,FRINGECAV
  PRIVATE KICKTR,KICKTP
  PRIVATE MULTIPOLE_FRINGER,MULTIPOLE_FRINGEP !,MULTIPOLE_FRINGE
  PRIVATE FRINGE_dipoleR,FRINGE_dipolep
  !  PRIVATE FRINGE_
  PRIVATE EDGER,EDGEP !,EDGE
  PRIVATE KICKR,KICKP !,KICK
  PRIVATE KICKEXR,KICKEXP
  PRIVATE INTER,INTEP,INTE
  PRIVATE INTEEXR,INTEEXP,INTE_strex
  PRIVATE SYMPINTR,SYMPINTP
  PRIVATE SYMPINTEXR,SYMPINTEXP
  PRIVATE KICK_SOLR,KICK_SOLP !,KICK_SOL
  PRIVATE FRINGE2QUADR,FRINGE2QUADP,FRINGE2QUAD
  PRIVATE INTESOLR,INTESOLP,INTESOL
  PRIVATE FACER,FACEP !,FACE
  PRIVATE NEWFACER,NEWFACEP
  PRIVATE EDGE_TRUE_PARALLELR,EDGE_TRUE_PARALLELP

  PRIVATE ZEROR_KTK,ZEROP_KTK,ZEROR_STREX,ZEROP_STREX,ZEROR_CAV4,ZEROP_CAV4,ZEROr_enge,ZEROp_enge
  PRIVATE ZEROR_superdrift,  ZEROP_superdrift
  PRIVATE ZEROR_KICKT3,ZEROP_KICKT3
  PRIVATE ALLOCKTK,KILLKTK
  PRIVATE GETMATR,GETMATD !,GETMAT
  PRIVATE PUSHKTKR,PUSHKTKD !,PUSHKTK
  PRIVATE KICKKTKR,KICKKTKP !,KICKKTK
  PRIVATE INTKTKR,INTKTKD,INTKTK
  PRIVATE SYMPINTKTKR,SYMPINTKTKD

  PRIVATE KICKPATH6R,KICKPATH6P
  PRIVATE EXP6R,EXP6D,EXPCOSY6   ! special for integrated exponential path length
  PRIVATE EXPR,EXPD,EXPCOSY

  PRIVATE ZEROR_TKT7,ZEROP_TKT7
  PRIVATE ALLOCTKT7,KILLTKT7
  PRIVATE GETMAT7R,GETMAT7D  !,GETMAT7
  PRIVATE PUSHTKT7R,PUSHTKT7D !,PUSHTKT7
  PRIVATE KICKTKT7R,KICKTKT7P !,KICKTKT7
  PRIVATE KICKPATHR,KICKPAThD !,KICKPATH
  PRIVATE INTTKT7R,INTTKT7D,INTTKT7
  PRIVATE SYMPINTTKT7R,SYMPINTTKT7D
  PRIVATE SYMPINTSOLR,SYMPINTSOLP
  PRIVATE GETMULB_SOLR,GETMULB_SOLP,GETMULB_SOL
  PRIVATE KICKMULR,KICKMULP !,KICKMUL
  PRIVATE GETNEWBR,GETNEWBP
  PRIVATE EXPR7,EXPD7,EXPCOSY7

  PRIVATE PUSH_NSMI_R,PUSH_NSMI_D
  PRIVATE PUSH_SSMI_R,PUSH_SSMI_D

  PRIVATE GETANBNR,GETANBNP,ZEROR_teapot,ZEROP_teapot,ALLOCTEAPOT,KILLTEAPOT
  PRIVATE GETAEBER,GETAEBEP
  PRIVATE SPROTR,SPROTP,SPROT
  PRIVATE SseCR,SseCP,Ssec
  PRIVATE SSECH1R,SSECH1P !,SSECH1
  PRIVATE SKICKR,SKICKP !,SKICK
  PRIVATE SINTER,SINTEP,SINTE
  PRIVATE SSYMPINTR,SSYMPINTP
  PRIVATE wedgeR,wedgeP !,wedge


  PRIVATE MONTR,MONTP,ZEROr_mon,ZEROP_mon
  PRIVATE MONTIR,MONTIP
  PRIVATE ECOLLIMATORR,ECOLLIMATORP
  PRIVATE RCOLLIMATORR,RCOLLIMATORP
  PRIVATE RCOLLIMATORiR,RCOLLIMATORiP  !,RCOLLIMATORi
  PRIVATE ECOLLIMATORiR,ECOLLIMATORiP  !,RCOLLIMATORi
  PRIVATE ZEROr_ECOL,ZEROP_ECOL,ZEROr_RCOL,ZEROP_RCOL,ZEROR_RAMP

  PRIVATE SEPR,SEPP,SYMPSEPR,SYMPSEPP !,SEPTTRACK
  !  PRIVATE IN,IN1,IN2
  INTEGER IN(4,4),IN1(10),IN2(10)
  PRIVATE ZEROR_CAV_TRAV,ZEROP_CAV_TRAV
  private fringe_TEAPOTr,fringe_TEAPOTp,INTER_TEAPOT,INTEP_TEAPOT
  PRIVATE fringe_STREXR,fringe_STREXP

  PRIVATE copypancake_el_elp,copypancake_elp_el,copypancake_el_el
  PRIVATE POINTERS_pancakeR,POINTERS_pancakep
  PRIVATE ZEROr_PANCAKE,ZEROP_PANCAKE
  PRIVATE rk4_pancaker,rk4_pancakeP
  PRIVATE FEVAL_pancaker,FEVAL_pancakeP
  PRIVATE INTPANCAKER,INTPANCAKEP,conv_to_xpr,conv_to_xpp,conv_to_pxr
  private conv_to_pxp
  private ADJUSTR_TIME_CAV4,ADJUSTp_TIME_CAV4,INTER_CAV4,INTEp_CAV4
  private INTER_STREX,INTEP_STREX,INTER_SOL5,INTEP_SOL5,INTER_KTK,INTEP_KTK
  private fringe_STRAIGHTr,fringe_STRAIGHTP
  private INTEr_dkd2,INTEP_dkd2,INTER_DRIFT1,INTEP_DRIFT1
  private INTER_TKTF,INTEP_TKTF
  private ADJUSTR_TIME_CAV_TRAV_OUT,ADJUSTP_TIME_CAV_TRAV_OUT
  private FRINGE_CAV_TRAVR,FRINGE_CAV_TRAVp,INTER_CAV_TRAV,INTEP_CAV_TRAV
  private INTER_PANCAKE,INTEP_PANCAKE,ADJUSTR_PANCAKE,ADJUSTP_PANCAKE
  private elliptical_b_r,elliptical_b_p  ! valishev
  PRIVATE TRACK_SUPER_FRINGER,TRACK_SUPER_FRINGEP

  INTEGER, PRIVATE :: TOTALPATH_FLAG
  !  private DRIFT_pancaker,DRIFT_pancakep,KICKPATH_pancaker,KICKPATH_pancakep
  ! using x and x'
  private fxr,fxp,f_m
  PRIVATE feval       !,rk4_m
  !  FOR CAV_TRAV
  PRIVATE A_TRANSR,A_TRANSP
  PRIVATE feval_CAVr,feval_CAVP,feval_CAV
  PRIVATE feval_CAV_bmadr,feval_CAV_bmadp
  private  FRINGECAVR_TRAV,FRINGECAVP_TRAV !,FRINGECAV_TRAV
  private rk2_cavr,rk2_cavp !,rk2_cav
  private rk4_cavr,rk4_cavp !,rk4_cav
  private rk6_cavr,rk6_cavp !,rk6_cav
  PRIVATE DRIFT_INTER,DRIFT_INTEP   ! NEW DRIFTS CUTABLE
  INTEGER,PRIVATE :: NMAXI=10000
  logical(lp) :: SPEED=.TRUE.
  logical(lp) ,TARGET :: OLD_IMPLEMENTATION_OF_SIXTRACK=.TRUE.
  real(dp), target :: phase0=-pi
  real(dp), target :: wedge_coeff(2)
  logical(lp), target :: MAD8_WEDGE=.TRUE.
  logical(lp) :: bug_intentional=.false.
 
  !  logical(lp) :: old_solenoid=.true.
  INTEGER :: N_CAV4_F=1
  INTEGER :: metcav=0, nstcav=0
  real(dp) :: xcav(1:6)=0.001d0, symplectic_check=1.d-10
  logical(lp) :: switch_to_fake=.true.
  
  
  ! stochastic radiation in straigth
  PRIVATE computeR_f4,computeP_f4,ZEROR_HE22,ZEROP_HE22
  PRIVATE DRIFTR_HE,DRIFTP_HE
  PRIVATE KICKR_HE,KICKP_HE,KICK_HE
  PRIVATE KICKPATHR_HE,KICKPATHP_HE
  PRIVATE INTR_HE,INTP_HE,INTR_HE_TOT,INTP_HE_TOT
  private ZEROr_DKD2,ZEROp_DKD2
  private GETELECTRICR,GETELECTRICP,electric_field_septumR,electric_field_septump
  !include "def_all_kind.f90"
  ! New home for element and elementp
  integer, parameter :: N_ENGE=5
  logical(lp),TARGET :: valishev=.false.
  logical(lp):: read_tc=.false.
  logical(lp):: solve_electric=.false.
  !  integer :: nvalishev=100
  PRIVATE feval_teapotr,feval_teapotP
  PRIVATE Abmad_TRANSR,Abmad_TRANSP 
  private rk2bmad_cavr,rk2bmad_cavp,rk4bmad_cavr,rk4bmad_cavp,rk6bmad_cavr,rk6bmad_cavp
  private track_slice4r,track_slice4p,PATCH_driftR,PATCH_driftp
  private  ZEROr_sol5,ZEROp_sol5
  logical(lp) :: tpsa_quad_sad=my_false
 
  INTERFACE TRACK_SLICE
!     MODULE PROCEDURE INTER_CAV4
!     MODULE PROCEDURE INTEP_CAV4
     MODULE PROCEDURE track_slice4r
     MODULE PROCEDURE track_slice4p
     MODULE PROCEDURE INTER_TEAPOT
     MODULE PROCEDURE INTEP_TEAPOT
     MODULE PROCEDURE INTER_STREX
     MODULE PROCEDURE INTEP_STREX
     MODULE PROCEDURE INTER_SOL5
     MODULE PROCEDURE INTEP_SOL5
     MODULE PROCEDURE INTER_KTK
     MODULE PROCEDURE INTEP_KTK
     MODULE PROCEDURE INTER_dkd2
     MODULE PROCEDURE INTEP_dkd2
     MODULE PROCEDURE INTER_DRIFT1
     MODULE PROCEDURE INTEP_DRIFT1
     MODULE PROCEDURE INTER_TKTF
     MODULE PROCEDURE INTEP_TKTF
     MODULE PROCEDURE INTER_CAV_TRAV
     MODULE PROCEDURE INTEP_CAV_TRAV
     MODULE PROCEDURE INTER_PANCAKE
     MODULE PROCEDURE INTEP_PANCAKE
     MODULE PROCEDURE INTR_HE
     MODULE PROCEDURE INTP_HE
     MODULE PROCEDURE INTER_superDRIFT1
     MODULE PROCEDURE INTEP_superDRIFT1
  END INTERFACE


  
  INTERFACE PATCH_drift
     MODULE PROCEDURE PATCH_driftR
     MODULE PROCEDURE PATCH_driftp
  END INTERFACE

  INTERFACE TRACK_SUPER_FRINGE
     MODULE PROCEDURE TRACK_SUPER_FRINGER
     MODULE PROCEDURE TRACK_SUPER_FRINGEP
  END INTERFACE

  INTERFACE ADJUST_PANCAKE
     MODULE PROCEDURE ADJUSTR_PANCAKE
     MODULE PROCEDURE ADJUSTP_PANCAKE
  END INTERFACE

  INTERFACE TRACK_FRINGE
     MODULE PROCEDURE fringe_STRAIGHTr
     MODULE PROCEDURE fringe_STRAIGHTp
  END INTERFACE

  INTERFACE fringe_TEAPOT
     MODULE PROCEDURE fringe_TEAPOTr
     MODULE PROCEDURE fringe_TEAPOTP
  END INTERFACE

  INTERFACE fringe_STREX
     MODULE PROCEDURE fringe_STREXR
     MODULE PROCEDURE fringe_STREXP
  END INTERFACE



  INTERFACE TRACK
     !     MODULE PROCEDURE DRFTR   ! MID DEFINED AS 1/2 L
     !     MODULE PROCEDURE DRFTP   ! MID
     !     MODULE PROCEDURE DRFTS
     MODULE PROCEDURE DRIFT_INTER   ! MID DEFINED AS 1/2 L
     MODULE PROCEDURE DRIFT_INTEP   ! MID

     MODULE PROCEDURE SYMPINTR ! MID IN INTE  DKD2
     MODULE PROCEDURE SYMPINTP ! MID IN INTE
     MODULE PROCEDURE SYMPINTEXR ! MID IN INTE
     MODULE PROCEDURE SYMPINTEXP ! MID IN INTE
     MODULE PROCEDURE KICKTR    ! MID DEFINED /12 KICK
     MODULE PROCEDURE KICKTP    ! MID DEFINED /12 KICK
     ! CAVITY THICK/THIN ELEMENT
     MODULE PROCEDURE CAVER     ! MID DEFINED /12 KICK   ALSO IN CAVITYR AND  CAVITYP
     MODULE PROCEDURE CAVEP      ! MID DEFINED /12 KICK
     MODULE PROCEDURE CAVER_TRAV     ! MID DEFINED /12 KICK   ALSO IN CAVITYR AND  CAVITYP
     MODULE PROCEDURE CAVEP_TRAV      ! MID DEFINED /12 KICK
     ! SOLENOID
     MODULE PROCEDURE SYMPINTSOLR
     MODULE PROCEDURE SYMPINTSOLP
     ! SLOW THICK ELEMENT    SIXTRACK
     MODULE PROCEDURE SYMPINTKTKR
     MODULE PROCEDURE SYMPINTKTKD
     ! FAST THICK ELEMENT
     MODULE PROCEDURE SYMPINTTKT7R
     MODULE PROCEDURE SYMPINTTKT7D
     ! THE THIN NORMAL SMI
     MODULE PROCEDURE PUSH_NSMI_R
     MODULE PROCEDURE PUSH_NSMI_D
     ! THE THIN SKEW SMI
     MODULE PROCEDURE PUSH_SSMI_R
     MODULE PROCEDURE PUSH_SSMI_D
     ! SECTOR (TEAPOT)
     MODULE PROCEDURE SSYMPINTR
     MODULE PROCEDURE SSYMPINTP
     ! MONITOR AND INSTRUMENT
     MODULE PROCEDURE MONTR
     MODULE PROCEDURE MONTP
     ! COLLIMATORS
     MODULE PROCEDURE RCOLLIMATORR
     MODULE PROCEDURE RCOLLIMATORP

     MODULE PROCEDURE ECOLLIMATORR
     MODULE PROCEDURE ECOLLIMATORP

     ! ELECTROSTATIC SEPTUM
     MODULE PROCEDURE SYMPSEPR
     MODULE PROCEDURE SYMPSEPP



     ! PANCAKE
     MODULE PROCEDURE INTPANCAKER
     MODULE PROCEDURE INTPANCAKEP

     ! HELICAL_DIPOLE
     MODULE PROCEDURE INTR_HE_TOT
     MODULE PROCEDURE INTP_HE_TOT

     ! superdrift
     MODULE PROCEDURE SUPER_DRIFT_R
     MODULE PROCEDURE SUPER_DRIFT_p

  END INTERFACE

  INTERFACE DRIFT
     MODULE PROCEDURE DRIFTR
     MODULE PROCEDURE DRIFTP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)

  END INTERFACE


  !@  INTERFACE DRIFT_pancake
  !    MODULE PROCEDURE DRIFT_pancaker
  !    MODULE PROCEDURE DRIFT_pancakep
  ! END INTERFACE

  INTERFACE MONTI
     MODULE PROCEDURE MONTIR
     MODULE PROCEDURE MONTIP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE

  INTERFACE RCOLLIMATORi
     MODULE PROCEDURE RCOLLIMATORiR
     MODULE PROCEDURE RCOLLIMATORiP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE

  INTERFACE ECOLLIMATORi
     MODULE PROCEDURE ECOLLIMATORiR
     MODULE PROCEDURE ECOLLIMATORiP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE

  INTERFACE KICKCAV
     MODULE PROCEDURE KICKCAVR
     MODULE PROCEDURE KICKCAVP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE

  INTERFACE Abmad_TRANS
     MODULE PROCEDURE Abmad_TRANSR
     MODULE PROCEDURE Abmad_TRANSP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE

  INTERFACE A_TRANS
     MODULE PROCEDURE A_TRANSR
     MODULE PROCEDURE A_TRANSP
  END INTERFACE

  INTERFACE feval_CAV
     MODULE PROCEDURE feval_CAVr
     MODULE PROCEDURE feval_CAVp
  END INTERFACE

  INTERFACE feval_CAV_bmad
     MODULE PROCEDURE feval_CAV_bmadr 
     MODULE PROCEDURE feval_CAV_bmadp
  END INTERFACE

  INTERFACE feval_teapot
     MODULE PROCEDURE feval_teapotr
     MODULE PROCEDURE feval_teapotP
  END INTERFACE

  INTERFACE rk2_cav
     MODULE PROCEDURE rk2_cavr
     MODULE PROCEDURE rk2_cavp
     MODULE PROCEDURE rk2bmad_cavr
     MODULE PROCEDURE rk2bmad_cavp
  END INTERFACE

  INTERFACE rk4_cav
     MODULE PROCEDURE rk4_cavr
     MODULE PROCEDURE rk4_cavp
     MODULE PROCEDURE rk4bmad_cavr
     MODULE PROCEDURE rk4bmad_cavp
  END INTERFACE

  INTERFACE rk6_cav
     MODULE PROCEDURE rk6_cavr
     MODULE PROCEDURE rk6_cavp
     MODULE PROCEDURE rk6bmad_cavr
     MODULE PROCEDURE rk6bmad_cavp
  END INTERFACE

  INTERFACE rk2_teapot
     MODULE PROCEDURE rk2_teapotr
     MODULE PROCEDURE rk2_teapotp
  END INTERFACE

  INTERFACE rk4_teapot
     MODULE PROCEDURE rk4_teapotr
     MODULE PROCEDURE rk4_teapotp
  END INTERFACE

  INTERFACE rk6_teapot
     MODULE PROCEDURE rk6_teapotr
     MODULE PROCEDURE rk6_teapotp
  END INTERFACE


  INTERFACE FRINGECAV
     MODULE PROCEDURE FRINGECAVR
     MODULE PROCEDURE FRINGECAVP       ! CAVITY FRINGE FIELDS
  END INTERFACE

  INTERFACE ADJUST_TIME_CAV4
     MODULE PROCEDURE ADJUSTR_TIME_CAV4
     MODULE PROCEDURE ADJUSTP_TIME_CAV4
  END INTERFACE

  INTERFACE ADJUST_TIME_CAV_TRAV_OUT
     MODULE PROCEDURE ADJUSTR_TIME_CAV_TRAV_OUT
     MODULE PROCEDURE ADJUSTP_TIME_CAV_TRAV_OUT
  END INTERFACE

  INTERFACE FRINGECAV_TRAV
     MODULE PROCEDURE FRINGECAVR_TRAV
     MODULE PROCEDURE FRINGECAVP_TRAV       ! CAVITY FRINGE FIELDS
  END INTERFACE

  INTERFACE FRINGE_CAV_TRAV
     MODULE PROCEDURE FRINGE_CAV_TRAVr
     MODULE PROCEDURE FRINGE_CAV_TRAVp       ! CAVITY FRINGE FIELDS
  END INTERFACE


  INTERFACE CAVITY
     MODULE PROCEDURE CAVITYR
     MODULE PROCEDURE CAVITYP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE

  INTERFACE MULTIPOLE_FRINGE
     MODULE PROCEDURE MULTIPOLE_FRINGER
     MODULE PROCEDURE MULTIPOLE_FRINGEP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE

  !  INTERFACE HIGH_FRINGE
  !     MODULE PROCEDURE HIGH_FRINGER
  !     MODULE PROCEDURE HIGH_FRINGEP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  !     MODULE PROCEDURE HIGH_FRINGES
  !  END INTERFACE

  INTERFACE FRINGE_dipole
     MODULE PROCEDURE FRINGE_dipoleR
     MODULE PROCEDURE FRINGE_dipoleP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE

  !  INTERFACE FRINGE__MULTI
  !     MODULE PROCEDURE FRINGER
  !  END INTERFACE

  INTERFACE FACE
     MODULE PROCEDURE FACER
     MODULE PROCEDURE FACEP       ! H1 AND H2 OF MAD FOR EXACT = FALSE
     MODULE PROCEDURE NEWFACER
     MODULE PROCEDURE NEWFACEP    ! H1 AND H2 OF MAD FOR EXACT = TRUE
  END INTERFACE

  !  INTERFACE FACE_MULTI
  !     MODULE PROCEDURE NEWFACER
  !  END INTERFACE


  INTERFACE EDGE
     MODULE PROCEDURE EDGER
     MODULE PROCEDURE EDGEP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE

  INTERFACE EDGE_TRUE_PARALLEL
     MODULE PROCEDURE EDGE_TRUE_PARALLELR
     MODULE PROCEDURE EDGE_TRUE_PARALLELP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE




  INTERFACE KICK
     MODULE PROCEDURE KICKR   ! NOT EXACT
     MODULE PROCEDURE KICKP
  END INTERFACE

  INTERFACE KICKEX
     MODULE PROCEDURE KICKEXR !  EXACT
     MODULE PROCEDURE KICKEXP
  END INTERFACE

  INTERFACE elliptical_b
     MODULE PROCEDURE elliptical_b_r !  EXACT
     MODULE PROCEDURE elliptical_b_p
  END INTERFACE



  !  INTERFACE KICK_multi
  !     MODULE PROCEDURE KICKR
  !     MODULE PROCEDURE KICKEXR !  EXACT
  !  END INTERFACE

  INTERFACE INTE
     MODULE PROCEDURE INTER   ! NOT EXACT !MID  dkd2
     MODULE PROCEDURE INTEP   ! MID
  END INTERFACE


  INTERFACE INTE_strex
     MODULE PROCEDURE INTEEXR ! EXACT
     MODULE PROCEDURE INTEEXP
  END INTERFACE

  INTERFACE KICK_SOL
     MODULE PROCEDURE KICK_SOLR
     MODULE PROCEDURE KICK_SOLP
  END INTERFACE

  !  INTERFACE KICK_SOL_old
  !     MODULE PROCEDURE KICK_SOLr_old
  !     MODULE PROCEDURE KICK_SOLp_old
  !  END INTERFACE

  INTERFACE FRINGE2QUAD
     MODULE PROCEDURE FRINGE2QUADR
     MODULE PROCEDURE FRINGE2QUADP
  END INTERFACE

  INTERFACE GETMULB_SOL
     MODULE PROCEDURE GETMULB_SOLR
     MODULE PROCEDURE GETMULB_SOLP
  END INTERFACE

  INTERFACE GETNEWB
     MODULE PROCEDURE GETNEWBR
     MODULE PROCEDURE GETNEWBP
  END INTERFACE

  INTERFACE KICKMUL
     MODULE PROCEDURE KICKMULR
     MODULE PROCEDURE KICKMULP
  END INTERFACE


  INTERFACE INTESOL
     MODULE PROCEDURE INTESOLR
     MODULE PROCEDURE INTESOLP
  END INTERFACE

  INTERFACE SEPTTRACK
     ! ELECTROSTATIC SEPTUM
     MODULE PROCEDURE SEPR
     MODULE PROCEDURE SEPP
  END INTERFACE
!!!! *************************************************************** !!!!
!!!! *                    slow thick element                       * !!!!
!!!! *************************************************************** !!!!

  !INTERFACE EQUAL
  !MODULE PROCEDURE copy_TKTF_TKTFP                              !
  !MODULE PROCEDURE copy_KTKP_KTK                              !
  !MODULE PROCEDURE copy_KTK_KTK                        !
  !end  INTERFACE

  INTERFACE copy
     MODULE PROCEDURE copypancake_el_elp
     MODULE PROCEDURE copypancake_elp_el
     MODULE PROCEDURE copypancake_el_el
  END INTERFACE



  INTERFACE POINTERS_pancake
     MODULE PROCEDURE POINTERS_pancakeR
     MODULE PROCEDURE POINTERS_pancakeP
  END INTERFACE

  INTERFACE ASSIGNMENT (=)
     MODULE PROCEDURE ZEROr_DKD2                 ! need upgrade
     MODULE PROCEDURE ZEROp_DKD2                  ! need upgrade
     MODULE PROCEDURE ZEROr_sol5                 ! need upgrade
     MODULE PROCEDURE ZEROp_sol5                  ! need upgrade
     MODULE PROCEDURE ZEROr_KTK                 ! need upgrade
     MODULE PROCEDURE ZEROP_KTK                  ! need upgrade
     MODULE PROCEDURE ZEROr_TKT7                 ! need upgrade
     MODULE PROCEDURE ZEROP_TKT7                  ! need upgrade
     MODULE PROCEDURE ZEROR_teapot
     MODULE PROCEDURE ZEROP_teapot
     MODULE PROCEDURE ZEROr_mon                 ! need upgrade
     MODULE PROCEDURE ZEROP_mon                  ! need upgrade
     MODULE PROCEDURE ZEROr_RCOL                 ! need upgrade
     MODULE PROCEDURE ZEROP_RCOL                 ! need upgrade
     MODULE PROCEDURE ZEROr_ECOL                ! need upgrade
     MODULE PROCEDURE ZEROP_ECOL                  ! need upgrade
     MODULE PROCEDURE ZEROR_STREX
     MODULE PROCEDURE ZEROP_STREX
     MODULE PROCEDURE ZEROR_CAV4
     MODULE PROCEDURE ZEROP_CAV4
     MODULE PROCEDURE ZEROR_CAV_TRAV
     MODULE PROCEDURE ZEROP_CAV_TRAV
     MODULE PROCEDURE ZEROR_KICKT3
     MODULE PROCEDURE ZEROP_KICKT3
     MODULE PROCEDURE ZEROr_PANCAKE                 ! need upgrade
     MODULE PROCEDURE ZEROP_PANCAKE                  ! need upgrade
     MODULE PROCEDURE ZEROR_HE22
     MODULE PROCEDURE ZEROP_HE22
     MODULE PROCEDURE ZEROr_enge
     MODULE PROCEDURE ZEROp_enge
     MODULE PROCEDURE ZEROR_RAMP
     MODULE PROCEDURE ZEROR_superdrift
     MODULE PROCEDURE ZEROP_superdrift
  END INTERFACE


  INTERFACE ALLOC
     MODULE PROCEDURE ALLOCKTK
     MODULE PROCEDURE ALLOCTKT7
     MODULE PROCEDURE ALLOCTEAPOT
  END INTERFACE

  INTERFACE KILL
     MODULE PROCEDURE KILLKTK
     MODULE PROCEDURE KILLTKT7
     MODULE PROCEDURE KILLTEAPOT
  END INTERFACE

  INTERFACE EXPCOSY6
     MODULE PROCEDURE EXP6R
     MODULE PROCEDURE EXP6D
  END INTERFACE

  INTERFACE GETMAT
     MODULE PROCEDURE GETMATR
     MODULE PROCEDURE GETMATD
  END INTERFACE

  INTERFACE INTKTK
     MODULE PROCEDURE INTKTKR
     MODULE PROCEDURE INTKTKD
  END INTERFACE

  INTERFACE PUSHKTK
     MODULE PROCEDURE PUSHKTKR
     MODULE PROCEDURE PUSHKTKD
  END INTERFACE

  INTERFACE KICKKTK
     MODULE PROCEDURE KICKKTKR
     MODULE PROCEDURE KICKKTKP
  END INTERFACE

  INTERFACE EXPCOSY
     MODULE PROCEDURE EXPR
     MODULE PROCEDURE EXPD
  END INTERFACE


!!!! *************************************************************** !!!!
!!!! *                    fast thick element                       * !!!!
!!!! *************************************************************** !!!!


  INTERFACE EXPCOSY7
     MODULE PROCEDURE EXPR7
     MODULE PROCEDURE EXPD7
  END INTERFACE


  INTERFACE GETMAT7
     MODULE PROCEDURE GETMAT7R
     MODULE PROCEDURE GETMAT7D
  END INTERFACE

  INTERFACE PUSHTKT7
     MODULE PROCEDURE PUSHTKT7R
     MODULE PROCEDURE PUSHTKT7D
  END INTERFACE

  INTERFACE KICKTKT7
     MODULE PROCEDURE KICKTKT7R
     MODULE PROCEDURE KICKTKT7P
  END INTERFACE

  INTERFACE KICKPATH
     MODULE PROCEDURE KICKPATHR
     MODULE PROCEDURE KICKPATHD
     MODULE PROCEDURE KICKPATH6R
     MODULE PROCEDURE KICKPATH6P
     MODULE PROCEDURE KICKPATHR_HE
     MODULE PROCEDURE KICKPATHP_HE
     !     MODULE PROCEDURE KICKPATH_pancaker
     !     MODULE PROCEDURE KICKPATH_pancakep
  END INTERFACE

  INTERFACE INTTKT7
     MODULE PROCEDURE INTTKT7R
     MODULE PROCEDURE INTTKT7D
  END INTERFACE

!!!! *************************************************************** !!!!
!!!! *           Beginning of the teapot element                   * !!!!
!!!! *************************************************************** !!!!

  INTERFACE GETANBN
!     MODULE PROCEDURE GETANBNR
!     MODULE PROCEDURE GETANBNP
     MODULE PROCEDURE GETAEBER
     MODULE PROCEDURE GETAEBEP
  END INTERFACE

  INTERFACE GETAEBE
     MODULE PROCEDURE GETAEBER
     MODULE PROCEDURE GETAEBEP
  END INTERFACE

  INTERFACE GETELECTRIC
     MODULE PROCEDURE GETELECTRICR
     MODULE PROCEDURE GETELECTRICP       ! FOR ELECTRIC TEAPOT
     MODULE PROCEDURE electric_field_septumR    ! FOR ESEPTUM
     MODULE PROCEDURE electric_field_septump    ! FOR ESEPTUM
  END INTERFACE

 ! INTERFACE GETMULB_TEAPOT
 !    MODULE PROCEDURE GETMULB_TEAPOTR
 !    MODULE PROCEDURE GETMULB_TEAPOTP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
 ! END INTERFACE


  INTERFACE SPROT
     MODULE PROCEDURE SPROTR
     MODULE PROCEDURE SPROTP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE

  INTERFACE Ssec
     MODULE PROCEDURE SsecR
     MODULE PROCEDURE SsecP       ! EXACT SECTOR SPLIT
  END INTERFACE

  INTERFACE SSECH1
     MODULE PROCEDURE SSECH1R
     MODULE PROCEDURE SSECH1P       ! EXACT SECTOR SPLIT
  END INTERFACE

  INTERFACE SPAR
     MODULE PROCEDURE SPARR
     MODULE PROCEDURE SPARP       ! EXACT PARALLEL FACE SPLIT
  END INTERFACE

  INTERFACE SKICK
     MODULE PROCEDURE SKICKR
     MODULE PROCEDURE SKICKP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE

  INTERFACE SINTE
     MODULE PROCEDURE SINTER
     MODULE PROCEDURE SINTEP
  END INTERFACE


  INTERFACE wedge
     MODULE PROCEDURE wedgeR
     MODULE PROCEDURE wedgeP       ! USE IN EXACT SECTOR BEND (INTEGRATION)
  END INTERFACE
  INTERFACE F_M
     MODULE PROCEDURE FXR
     MODULE PROCEDURE FXP
  END INTERFACE

  INTERFACE feval
     MODULE PROCEDURE FEVAL_pancaker
     MODULE PROCEDURE FEVAL_pancakeP
  END INTERFACE

  INTERFACE conv_to_xp
     MODULE PROCEDURE conv_to_xpr
     MODULE PROCEDURE conv_to_xpp
  END INTERFACE
  INTERFACE conv_to_px
     MODULE PROCEDURE conv_to_pxr
     MODULE PROCEDURE conv_to_pxp
  END INTERFACE


  INTERFACE RK4_M
     MODULE PROCEDURE rk4_pancaker
     MODULE PROCEDURE rk4_pancakeP
  END INTERFACE

!!!!!!!  HELICAL


  INTERFACE compute_f4
     MODULE PROCEDURE computeR_f4
     MODULE PROCEDURE computeP_f4
  END INTERFACE

  INTERFACE DRIFT
     MODULE PROCEDURE DRIFTR_HE
     MODULE PROCEDURE DRIFTP_HE
  END INTERFACE

  INTERFACE KICK_HE
     MODULE PROCEDURE KICKR_HE
     MODULE PROCEDURE KICKP_HE
  END INTERFACE

contains

  SUBROUTINE PATCH_driftR(C,X,k,PATCH,dir)
    implicit none
    ! MISALIGNS REAL FIBRES IN PTC ORDER FOR FORWARD AND BACKWARD FIBRES
    TYPE(SUPERDRIFT1),INTENT(INOUT):: C
    real(dp), INTENT(INOUT):: X(6)
    integer(2),intent(in) :: dir
    logical(lp),INTENT(IN):: PATCH
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

  
       X(3)=C%A_X1*X(3);X(4)=C%A_X1*X(4);
       CALL ROT_YZ(C%A_ANG(1),X,C%P%BETA0,PATCH,k%TIME)
       CALL ROT_XZ(C%A_ANG(2),X,C%P%BETA0,PATCH,k%TIME)
       CALL ROT_XY(C%A_ANG(3),X)  !,PATCH)
       CALL TRANS(C%A_D,X,C%P%BETA0,PATCH,k%TIME)
       X(3)=C%A_X2*X(3);X(4)=C%A_X2*X(4);
    


  END SUBROUTINE PATCH_driftR


  SUBROUTINE PATCH_driftp(C,X,k,PATCH,dir)
    implicit none
    ! MISALIGNS REAL FIBRES IN PTC ORDER FOR FORWARD AND BACKWARD FIBRES
    TYPE(SUPERDRIFT1p),INTENT(INOUT):: C
    TYPE(REAL_8), INTENT(INOUT):: X(6)
    integer(2),intent(in) :: dir
    logical(lp),INTENT(IN):: PATCH
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

       X(3)=C%A_X1*X(3);X(4)=C%A_X1*X(4);
       CALL ROT_YZ(C%A_ANG(1),X,C%P%BETA0,PATCH,k%TIME)
       CALL ROT_XZ(C%A_ANG(2),X,C%P%BETA0,PATCH,k%TIME)
       CALL ROT_XY(C%A_ANG(3),X)  !,PATCH)
       CALL TRANS(C%A_D,X,C%P%BETA0,PATCH,k%TIME)
       X(3)=C%A_X2*X(3);X(4)=C%A_X2*X(4);


  END SUBROUTINE PATCH_driftp

  SUBROUTINE INTER_DRIFT1(EL,X,k)
    IMPLICIT NONE
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(DRIFT1),INTENT(IN):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) DH,DD

    SELECT CASE(EL%P%METHOD)
    CASE(2,4,6)
       DH=EL%L/EL%P%NST
       DD=EL%P%LD/EL%P%NST

       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)


    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

  END SUBROUTINE INTER_DRIFT1



  SUBROUTINE INTEP_DRIFT1(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(DRIFT1P),INTENT(IN):: EL
    TYPE(REAL_8) DH
    real(dp) DD
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ALLOC(DH)
    SELECT CASE(EL%P%METHOD)
    CASE(2,4,6)
       DH=EL%L/EL%P%NST
       DD=EL%P%LD/EL%P%NST




       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)


    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

    CALL KILL(DH)

  END SUBROUTINE INTEP_DRIFT1


  SUBROUTINE INTER_superDRIFT1(EL,X,k)
    IMPLICIT NONE
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(SUPERDRIFT1),INTENT(IN):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) DH,DD

    SELECT CASE(EL%P%METHOD)
    CASE(2,4,6)
       DH=EL%L/EL%P%NST
       DD=EL%P%LD/EL%P%NST

       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)


    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

  END SUBROUTINE INTER_superDRIFT1

  SUBROUTINE INTEP_superDRIFT1(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(SUPERDRIFT1p),INTENT(IN):: EL
    TYPE(REAL_8) DH
    real(dp) DD
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ALLOC(DH)
    SELECT CASE(EL%P%METHOD)
    CASE(2,4,6)
       DH=EL%L/EL%P%NST
       DD=EL%P%LD/EL%P%NST




       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)


    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

    CALL KILL(DH)

  END SUBROUTINE INTEP_superDRIFT1


  SUBROUTINE SUPER_DRIFT_p(EL,X,k)
    IMPLICIT NONE
    type(real_8),INTENT(INOUT):: X(6)
 
    TYPE(SUPERDRIFT1p),TARGET,INTENT(INOUT):: EL
    INTEGER I 
    integer(2) j 
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


!    IF(EL%N_BESSEL>0)]
     j=1
 CALL TRACK_SUPER_FRINGE(EL,X,k,j)

    !    TOTALPATH_FLAG=k%TOTALPATH
    !    k%TOTALPATH=CAVITY_TOTALPATH



    DO I=1,EL%P%NST
       call track_slice(EL,X,k)
    ENDDO
    j=2
    CALL TRACK_SUPER_FRINGE(EL,X,k,j)


  END SUBROUTINE SUPER_DRIFT_p

  SUBROUTINE SUPER_DRIFT_R(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(SUPERDRIFT1),TARGET,INTENT(INOUT):: EL
    INTEGER I 
    integer(2) j 
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


!    IF(EL%N_BESSEL>0)]
 j=1
 CALL TRACK_SUPER_FRINGE(EL,X,k,j)

    !    TOTALPATH_FLAG=k%TOTALPATH
    !    k%TOTALPATH=CAVITY_TOTALPATH

    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    DO I=1,EL%P%NST
       IF(.NOT.PRESENT(MID)) call track_slice(EL,X,k)
       IF(PRESENT(MID)) CALL XMID(MID,X,I)
    ENDDO

  j=2
    CALL TRACK_SUPER_FRINGE(EL,X,k,j)


  END SUBROUTINE SUPER_DRIFT_R

  SUBROUTINE TRACK_SUPER_FRINGER(C,X,K,J)
    implicit none
    logical(lp) :: doneitt=.true.
    TYPE(SUPERDRIFT1),TARGET,INTENT(INOUT):: C
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(INTERNAL_STATE)  K
    !    TYPE(INTERNAL_STATE), INTENT(IN) :: K
    logical(lp) ou,patch
    INTEGER(2) PATCHT,PATCHE,J
    real(dp), POINTER :: P0,B0
    real(dp) b1


    PATCHT=c%TIME ;PATCHE=c%ENERGY ;


    b1=C%p%BETA0

    IF(PATCHE/=0) THEN

             P0=>C%P0b
             B0=>C%B0b

             X(2)=X(2)*P0/C%P%P0C
             X(4)=X(4)*P0/C%P%P0C
             IF(k%TIME)THEN
                X(5)=root(1.0_dp+2.0_dp*X(5)/B0+X(5)**2)  !X(5) = 1+DP/P0C_OLD
                X(5)=X(5)*P0/C%P%P0C-1.0_dp !X(5) = DP/P0C_NEW
                X(5)=(2.0_dp*X(5)+X(5)**2)/(root(1.0_dp/C%P%BETA0**2+2.0_dp*X(5)+X(5)**2)+1.0_dp/C%P%BETA0)
             ELSE
                X(5)=(1.0_dp+X(5))*P0/C%P%P0C-1.0_dp
             ENDIF           

endif

    ! The chart frame of reference is located here implicitely

       patch=C%P%EXACT
       CALL PATCH_drift(C,X,k,PATCH,J)


    IF(PATCHT/=0.AND.K%TOTALPATH==0) THEN
      if(K%time) then
       X(6)=X(6)-C%a_T/c%p%beta0
      else
       X(6)=X(6)-C%a_T
      endif
    ENDIF

  END SUBROUTINE TRACK_SUPER_FRINGER


  SUBROUTINE TRACK_SUPER_FRINGEP(C,X,K,J)
    implicit none
    logical(lp) :: doneitt=.true.
    TYPE(SUPERDRIFT1P),TARGET,INTENT(INOUT):: C
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(INTERNAL_STATE)  K
    !    TYPE(INTERNAL_STATE), INTENT(IN) :: K
    logical(lp) ou,patch
    INTEGER(2) PATCHT,PATCHE,J
    real(dp), POINTER :: P0,B0
    real(dp) b1


    PATCHT=c%TIME ;PATCHE=c%ENERGY ;


    b1=C%p%BETA0

    IF(PATCHE/=0) THEN

             P0=>C%P0b
             B0=>C%B0b

             X(2)=X(2)*P0/C%P%P0C
             X(4)=X(4)*P0/C%P%P0C
             IF(k%TIME)THEN
                X(5)=SQRT(1.0_dp+2.0_dp*X(5)/B0+X(5)**2)  !X(5) = 1+DP/P0C_OLD
                X(5)=X(5)*P0/C%P%P0C-1.0_dp !X(5) = DP/P0C_NEW
                X(5)=(2.0_dp*X(5)+X(5)**2)/(SQRT(1.0_dp/C%P%BETA0**2+2.0_dp*X(5)+X(5)**2)+1.0_dp/C%P%BETA0)
             ELSE
                X(5)=(1.0_dp+X(5))*P0/C%P%P0C-1.0_dp
             ENDIF           

endif

    ! The chart frame of reference is located here implicitely

       patch=C%P%EXACT
       CALL PATCH_drift(C,X,k,PATCH,J)


    IF(PATCHT/=0.AND.K%TOTALPATH==0) THEN
      if(K%time) then
       X(6)=X(6)-C%a_T/c%p%beta0
      else
       X(6)=X(6)-C%a_T
      endif
    ENDIF

  END SUBROUTINE TRACK_SUPER_FRINGEP




  SUBROUTINE DRIFT_INTER(EL,X,K,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(DRIFT1),INTENT(IN):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    DO I=1,EL%P%NST
       IF(.NOT.PRESENT(MID)) CALL TRACK_SLICE(EL,X,k)
       IF(PRESENT(MID)) CALL XMID(MID,X,I)
    ENDDO


  END SUBROUTINE DRIFT_INTER





  SUBROUTINE DRIFT_INTEP(EL,X,K)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    ! TYPE(WORM_8),OPTIONAL,INTENT(INOUT):: MID
    TYPE(DRIFT1P),INTENT(IN):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    DO I=1,EL%P%NST
       CALL TRACK_SLICE(EL,X,k)
    ENDDO


  END SUBROUTINE DRIFT_INTEP

  ! tracking fringe areas

  SUBROUTINE fringe_STRAIGHTr(EL,EL5,EL6,EL7,X,k,J)
    IMPLICIT NONE
    TYPE(DKD2),OPTIONAL,INTENT(IN):: EL
    TYPE(SOL5),OPTIONAL,INTENT(INOUT):: EL5
    TYPE(KTK),OPTIONAL,INTENT(INOUT):: EL6
    TYPE(TKTF),OPTIONAL,INTENT(INOUT):: EL7
    integer,INTENT(IN):: J
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    ! J=1 front
    IF(PRESENT(EL)) THEN
       !       DO I=1,B%N
       !        IF(B%U(i)) CYCLE
       !         X=BEAM_IN_X(B,I)

       if(J==1) then
          if(EL%P%DIR==1) THEN
             CALL EDGE(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,1,X,k)
             IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             IF(el%p%permfringe==2.or.el%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,1,X,k)
          ELSE
             CALL EDGE(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,2,X,k)
             IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             IF(el%p%permfringe==2.or.el%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,2,X,k)
          ENDIF
       else
          if(EL%P%DIR==1) THEN
             IF(el%p%permfringe==2.or.el%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,2,X,k)
             IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             CALL EDGE(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,2,X,k)
          ELSE
             IF(el%p%permfringe==2.or.el%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,1,X,k)
             IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             CALL EDGE(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,1,X,k)
          ENDIF
       ENDIF
       !         CALL X_IN_BEAM(X,B,I)

    ELSEIF(PRESENT(EL6)) THEN
       !       DO I=1,B%N
       !        IF(B%U(i)) CYCLE
       !         X=BEAM_IN_X(B,I)

       if(J==1) then
          if(EL6%P%DIR==1) THEN
             CALL EDGE(EL6%P,EL6%BN,EL6%H1,EL6%H2,EL6%FINT,EL6%HGAP,1,X,k)
             IF(k%FRINGE.or.el6%p%permfringe==1.or.el6%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL6%P,EL6%AN,EL6%BN,1,X,k)
             IF(el6%p%permfringe==2.or.el6%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL6%P,EL6%bn(2),EL6%an(2),EL6%VA,EL6%VS,1,X,k)
          ELSE
             CALL EDGE(EL6%P,EL6%BN,EL6%H1,EL6%H2,EL6%FINT,EL6%HGAP,2,X,k)
             IF(k%FRINGE.or.el6%p%permfringe==1.or.el6%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL6%P,EL6%AN,EL6%BN,2,X,k)
             IF(el6%p%permfringe==2.or.el6%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL6%P,EL6%bn(2),EL6%an(2),EL6%VA,EL6%VS,2,X,k)
          ENDIF
       else
          if(EL6%P%DIR==1) THEN
             IF(el6%p%permfringe==2.or.el6%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL6%P,EL6%bn(2),EL6%an(2),EL6%VA,EL6%VS,2,X,k)
             IF(k%FRINGE.or.el6%p%permfringe==1.or.el6%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL6%P,EL6%AN,EL6%BN,2,X,k)
             CALL EDGE(EL6%P,EL6%BN,EL6%H1,EL6%H2,EL6%FINT,EL6%HGAP,2,X,k)
          ELSE
             IF(el6%p%permfringe==2.or.el6%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL6%P,EL6%bn(2),EL6%an(2),EL6%VA,EL6%VS,1,X,k)
             IF(k%FRINGE.or.el6%p%permfringe==1.or.el6%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL6%P,EL6%AN,EL6%BN,1,X,k)
             CALL EDGE(EL6%P,EL6%BN,EL6%H1,EL6%H2,EL6%FINT,EL6%HGAP,1,X,k)
          ENDIF
       ENDIF
       !         CALL X_IN_BEAM(X,B,I)

    ELSEIF(PRESENT(EL5)) THEN
       !       DO I=1,B%N
       !        IF(B%U(i)) CYCLE
       !         X=BEAM_IN_X(B,I)

       if(J==1) then
          if(EL5%P%DIR==1) THEN
             CALL EDGE(EL5%P,EL5%BN,EL5%H1,EL5%H2,EL5%FINT,EL5%HGAP,1,X,k)
             IF(k%FRINGE.or.el5%p%permfringe==1.or.el5%p%permfringe==3) &
                CALL MULTIPOLE_FRINGE(EL5%P,EL5%AN,EL5%BN,1,X,k)
             IF(el5%p%permfringe==2.or.el5%p%permfringe==3) & 
               CALL FRINGE2QUAD(EL5%P,EL5%bn(2),EL5%an(2),EL5%VA,EL5%VS,1,X,k)
          ELSE
             CALL EDGE(EL5%P,EL5%BN,EL5%H1,EL5%H2,EL5%FINT,EL5%HGAP,2,X,k)
              IF(k%FRINGE.or.el5%p%permfringe==1.or.el5%p%permfringe==3) &
                 CALL MULTIPOLE_FRINGE(EL5%P,EL5%AN,EL5%BN,2,X,k)
             IF(el5%p%permfringe==2.or.el5%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL5%P,EL5%bn(2),EL5%an(2),EL5%VA,EL5%VS,2,X,k)
          ENDIF
       else
          if(EL5%P%DIR==1) THEN
             IF(el5%p%permfringe==2.or.el5%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL5%P,EL5%bn(2),EL5%an(2),EL5%VA,EL5%VS,2,X,k)
              IF(k%FRINGE.or.el5%p%permfringe==1.or.el5%p%permfringe==3) &
                       CALL MULTIPOLE_FRINGE(EL5%P,EL5%AN,EL5%BN,2,X,k)
             CALL EDGE(EL5%P,EL5%BN,EL5%H1,EL5%H2,EL5%FINT,EL5%HGAP,2,X,k)
          ELSE
             IF(el5%p%permfringe==2.or.el5%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL5%P,EL5%bn(2),EL5%an(2),EL5%VA,EL5%VS,1,X,k)
              IF(k%FRINGE.or.el5%p%permfringe==1.or.el5%p%permfringe==3) &
                        CALL MULTIPOLE_FRINGE(EL5%P,EL5%AN,EL5%BN,1,X,k)
             CALL EDGE(EL5%P,EL5%BN,EL5%H1,EL5%H2,EL5%FINT,EL5%HGAP,1,X,k)
          ENDIF
       ENDIF

    ELSEIF(PRESENT(EL7)) THEN

       if(J==1) then
          if(EL7%P%DIR==1) THEN
             CALL EDGE(EL7%P,EL7%BN,EL7%H1,EL7%H2,EL7%FINT,EL7%HGAP,1,X,k)
             IF(k%FRINGE.or.el7%p%permfringe==1.or.el7%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL7%P,EL7%AN,EL7%BN,1,X,k)
             IF(el7%p%permfringe==2.or.el7%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL7%P,EL7%bn(2),EL7%an(2),EL7%VA,EL7%VS,1,X,k)
          ELSE
             CALL EDGE(EL7%P,EL7%BN,EL7%H1,EL7%H2,EL7%FINT,EL7%HGAP,2,X,k)
             IF(k%FRINGE.or.el7%p%permfringe==1.or.el7%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL7%P,EL7%AN,EL7%BN,2,X,k)
             IF(el7%p%permfringe==2.or.el7%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL7%P,EL7%bn(2),EL7%an(2),EL7%VA,EL7%VS,2,X,k)
          ENDIF
       else
          if(EL7%P%DIR==1) THEN
             IF(el7%p%permfringe==2.or.el7%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL7%P,EL7%bn(2),EL7%an(2),EL7%VA,EL7%VS,2,X,k)
             IF(k%FRINGE.or.el7%p%permfringe==1.or.el7%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL7%P,EL7%AN,EL7%BN,2,X,k)
             CALL EDGE(EL7%P,EL7%BN,EL7%H1,EL7%H2,EL7%FINT,EL7%HGAP,2,X,k)
          ELSE
             IF(el7%p%permfringe==2.or.el7%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL7%P,EL7%bn(2),EL7%an(2),EL7%VA,EL7%VS,1,X,k)
             IF(k%FRINGE.or.el7%p%permfringe==1.or.el7%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL7%P,EL7%AN,EL7%BN,1,X,k)
             CALL EDGE(EL7%P,EL7%BN,EL7%H1,EL7%H2,EL7%FINT,EL7%HGAP,1,X,k)
          ENDIF
       ENDIF


    ENDIF
  END SUBROUTINE fringe_STRAIGHTr


  SUBROUTINE fringe_STRAIGHTP(EL,EL5,EL6,EL7,X,k,J)
    IMPLICIT NONE
    TYPE(DKD2P),OPTIONAL,INTENT(IN):: EL
    TYPE(SOL5P),OPTIONAL,INTENT(INOUT):: EL5
    TYPE(KTKP),OPTIONAL,INTENT(INOUT):: EL6
    TYPE(TKTFP),OPTIONAL,INTENT(INOUT):: EL7
    integer,INTENT(IN):: J
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K



    IF(PRESENT(EL)) THEN
       !       DO I=1,B%N
       !        IF(B%U(i)) CYCLE
       !         X=BEAM_IN_X(B,I)

       if(J==1) then
          if(EL%P%DIR==1) THEN
             CALL EDGE(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,1,X,k)
             IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             IF(el%p%permfringe==2.or.el%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,1,X,k)
          ELSE
             CALL EDGE(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,2,X,k)
             IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             IF(el%p%permfringe==2.or.el%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,2,X,k)
          ENDIF
       else
          if(EL%P%DIR==1) THEN
             IF(el%p%permfringe==2.or.el%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,2,X,k)
             IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             CALL EDGE(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,2,X,k)
          ELSE
             IF(el%p%permfringe==2.or.el%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,1,X,k)
             IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             CALL EDGE(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,1,X,k)
          ENDIF
       ENDIF
       !         CALL X_IN_BEAM(X,B,I)

    ELSEIF(PRESENT(EL6)) THEN
       !       DO I=1,B%N
       !        IF(B%U(i)) CYCLE
       !         X=BEAM_IN_X(B,I)

       if(J==1) then
          if(EL6%P%DIR==1) THEN
             CALL EDGE(EL6%P,EL6%BN,EL6%H1,EL6%H2,EL6%FINT,EL6%HGAP,1,X,k)
             IF(k%FRINGE.or.el6%p%permfringe==1.or.el6%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL6%P,EL6%AN,EL6%BN,1,X,k)
             IF(el6%p%permfringe==2.or.el6%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL6%P,EL6%bn(2),EL6%an(2),EL6%VA,EL6%VS,1,X,k)
          ELSE
             CALL EDGE(EL6%P,EL6%BN,EL6%H1,EL6%H2,EL6%FINT,EL6%HGAP,2,X,k)
             IF(k%FRINGE.or.el6%p%permfringe==1.or.el6%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL6%P,EL6%AN,EL6%BN,2,X,k)
             IF(el6%p%permfringe==2.or.el6%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL6%P,EL6%bn(2),EL6%an(2),EL6%VA,EL6%VS,2,X,k)
          ENDIF
       else
          if(EL6%P%DIR==1) THEN
             IF(el6%p%permfringe==2.or.el6%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL6%P,EL6%bn(2),EL6%an(2),EL6%VA,EL6%VS,2,X,k)
             IF(k%FRINGE.or.el6%p%permfringe==1.or.el6%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL6%P,EL6%AN,EL6%BN,2,X,k)
             CALL EDGE(EL6%P,EL6%BN,EL6%H1,EL6%H2,EL6%FINT,EL6%HGAP,2,X,k)
          ELSE
             IF(el6%p%permfringe==2.or.el6%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL6%P,EL6%bn(2),EL6%an(2),EL6%VA,EL6%VS,1,X,k)
             IF(k%FRINGE.or.el6%p%permfringe==1.or.el6%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL6%P,EL6%AN,EL6%BN,1,X,k)
             CALL EDGE(EL6%P,EL6%BN,EL6%H1,EL6%H2,EL6%FINT,EL6%HGAP,1,X,k)
          ENDIF
       ENDIF
       !         CALL X_IN_BEAM(X,B,I)

    ELSEIF(PRESENT(EL5)) THEN
       !       DO I=1,B%N
       !        IF(B%U(i)) CYCLE
       !         X=BEAM_IN_X(B,I)

       if(J==1) then
          if(EL5%P%DIR==1) THEN
             CALL EDGE(EL5%P,EL5%BN,EL5%H1,EL5%H2,EL5%FINT,EL5%HGAP,1,X,k)
             IF(k%FRINGE.or.el5%p%permfringe==1.or.el5%p%permfringe==3) &
                CALL MULTIPOLE_FRINGE(EL5%P,EL5%AN,EL5%BN,1,X,k)
             IF(el5%p%permfringe==2.or.el5%p%permfringe==3) & 
               CALL FRINGE2QUAD(EL5%P,EL5%bn(2),EL5%an(2),EL5%VA,EL5%VS,1,X,k)
          ELSE
             CALL EDGE(EL5%P,EL5%BN,EL5%H1,EL5%H2,EL5%FINT,EL5%HGAP,2,X,k)
              IF(k%FRINGE.or.el5%p%permfringe==1.or.el5%p%permfringe==3) &
                 CALL MULTIPOLE_FRINGE(EL5%P,EL5%AN,EL5%BN,2,X,k)
             IF(el5%p%permfringe==2.or.el5%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL5%P,EL5%bn(2),EL5%an(2),EL5%VA,EL5%VS,2,X,k)
          ENDIF
       else
          if(EL5%P%DIR==1) THEN
             IF(el5%p%permfringe==2.or.el5%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL5%P,EL5%bn(2),EL5%an(2),EL5%VA,EL5%VS,2,X,k)
              IF(k%FRINGE.or.el5%p%permfringe==1.or.el5%p%permfringe==3) &
                       CALL MULTIPOLE_FRINGE(EL5%P,EL5%AN,EL5%BN,2,X,k)
             CALL EDGE(EL5%P,EL5%BN,EL5%H1,EL5%H2,EL5%FINT,EL5%HGAP,2,X,k)
          ELSE
             IF(el5%p%permfringe==2.or.el5%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL5%P,EL5%bn(2),EL5%an(2),EL5%VA,EL5%VS,1,X,k)
              IF(k%FRINGE.or.el5%p%permfringe==1.or.el5%p%permfringe==3) &
                        CALL MULTIPOLE_FRINGE(EL5%P,EL5%AN,EL5%BN,1,X,k)
             CALL EDGE(EL5%P,EL5%BN,EL5%H1,EL5%H2,EL5%FINT,EL5%HGAP,1,X,k)
          ENDIF
       ENDIF

    ELSEIF(PRESENT(EL7)) THEN

       if(J==1) then
          if(EL7%P%DIR==1) THEN
             CALL EDGE(EL7%P,EL7%BN,EL7%H1,EL7%H2,EL7%FINT,EL7%HGAP,1,X,k)
             IF(k%FRINGE.or.el7%p%permfringe==1.or.el7%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL7%P,EL7%AN,EL7%BN,1,X,k)
             IF(el7%p%permfringe==2.or.el7%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL7%P,EL7%bn(2),EL7%an(2),EL7%VA,EL7%VS,1,X,k)
          ELSE
             CALL EDGE(EL7%P,EL7%BN,EL7%H1,EL7%H2,EL7%FINT,EL7%HGAP,2,X,k)
             IF(k%FRINGE.or.el7%p%permfringe==1.or.el7%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL7%P,EL7%AN,EL7%BN,2,X,k)
             IF(el7%p%permfringe==2.or.el7%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL7%P,EL7%bn(2),EL7%an(2),EL7%VA,EL7%VS,2,X,k)
          ENDIF
       else
          if(EL7%P%DIR==1) THEN
             IF(el7%p%permfringe==2.or.el7%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL7%P,EL7%bn(2),EL7%an(2),EL7%VA,EL7%VS,2,X,k)
             IF(k%FRINGE.or.el7%p%permfringe==1.or.el7%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL7%P,EL7%AN,EL7%BN,2,X,k)
             CALL EDGE(EL7%P,EL7%BN,EL7%H1,EL7%H2,EL7%FINT,EL7%HGAP,2,X,k)
          ELSE
             IF(el7%p%permfringe==2.or.el7%p%permfringe==3) & 
             CALL FRINGE2QUAD(EL7%P,EL7%bn(2),EL7%an(2),EL7%VA,EL7%VS,1,X,k)
             IF(k%FRINGE.or.el7%p%permfringe==1.or.el7%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL7%P,EL7%AN,EL7%BN,1,X,k)
             CALL EDGE(EL7%P,EL7%BN,EL7%H1,EL7%H2,EL7%FINT,EL7%HGAP,1,X,k)
          ENDIF
       ENDIF


    ENDIF
  END SUBROUTINE fringe_STRAIGHTP



  SUBROUTINE ADJUSTR_TIME_CAV4(EL,X,k,J)
    IMPLICIT NONE
    REAL(DP), INTENT(INOUT)::  X(6)
    TYPE(CAV4),INTENT(INOUT):: EL
    integer,INTENT(IN):: J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(J==1) THEN
       EL%DELTA_E=X(5)
       IF(k%NOCAVITY.and.(.not.EL%always_on)) RETURN

       IF(EL%THIN) THEN
          CALL CAVITY(EL,X,k)
          EL%DELTA_E=(X(5)-EL%DELTA_E)*EL%P%P0C
          RETURN
       ENDIF

    ELSE
       IF(EL%THIN) RETURN

       if(k%TIME) then
          X(6)=X(6)-(el%CAVITY_TOTALPATH-k%TOTALPATH)*EL%P%LD/EL%P%BETA0
       else
          X(6)=X(6)-(el%CAVITY_TOTALPATH-k%TOTALPATH)*EL%P%LD
       endif

       EL%DELTA_E=(X(5)-EL%DELTA_E)*EL%P%P0C
    ENDIF

  END SUBROUTINE ADJUSTR_TIME_CAV4

  SUBROUTINE ADJUSTP_TIME_CAV4(EL,X,k,J)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT)::  X(6)
    TYPE(CAV4P),INTENT(INOUT):: EL
    integer,INTENT(IN):: J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(J==1) THEN
       EL%DELTA_E=X(5)
       IF(k%NOCAVITY.and.(.not.EL%always_on)) RETURN

       IF(EL%THIN) THEN
          CALL CAVITY(EL,X,k)
          EL%DELTA_E=(X(5)-EL%DELTA_E)*EL%P%P0C
          RETURN
       ENDIF

    ELSE
       IF(EL%THIN) RETURN

       if(k%TIME) then
          X(6)=X(6)-(el%CAVITY_TOTALPATH-k%TOTALPATH)*EL%P%LD/EL%P%BETA0
       else
          X(6)=X(6)-(el%CAVITY_TOTALPATH-k%TOTALPATH)*EL%P%LD
       endif

       EL%DELTA_E=(X(5)-EL%DELTA_E)*EL%P%P0C
    ENDIF

  END SUBROUTINE ADJUSTP_TIME_CAV4

  SUBROUTINE track_slice4r(EL,X,kt,zi)
    IMPLICIT NONE
    real(dp), INTENT(INOUT) ::  X(6)
    integer zi
    TYPE(CAV4),INTENT(INOUT):: EL
    TYPE(INTERNAL_STATE) kt !,OPTIONAL :: K
    
    if(el%n_bessel/=-1) then
     call INTER_CAV4(EL,X,kt)
    else
     call INTER_CAVbmad4(EL,X,kt,zi)
    endif    
  end SUBROUTINE track_slice4r

  SUBROUTINE INTER_CAV4(EL,X,kt)
    IMPLICIT NONE
    real(dp), INTENT(INOUT) ::  X(6)

    TYPE(CAV4),INTENT(INOUT):: EL
    real(dp) D,DH,DD
    real(dp) D1,D2,DK1,DK2
    real(dp) DD1,DD2
    real(dp) DF(4),DK(4),DDF(4)
    INTEGER I,J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    TYPE(INTERNAL_STATE) kt !,OPTIONAL :: K

    IF(EL%THIN) return
    k=kt
    TOTALPATH_FLAG=k%TOTALPATH
    k%TOTALPATH=el%CAVITY_TOTALPATH



    SELECT CASE(EL%P%METHOD)
    CASE(2)
       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       DD=EL%P%LD/2.0_dp/EL%P%NST

       !       DO I=1,B%N

       !        X=BEAM_IN_X(B,I)
       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICKCAV (EL,D,X,k)
       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)


    CASE(4)
       D1=EL%L*FD1/EL%P%NST
       D2=EL%L*FD2/EL%P%NST
       DD1=EL%P%LD*FD1/EL%P%NST
       DD2=EL%P%LD*FD2/EL%P%NST
       DK1=EL%L*FK1/EL%P%NST
       DK2=EL%L*FK2/EL%P%NST

       !       DO I=1,B%N

       !        X=BEAM_IN_X(B,I)
       CALL DRIFT(D1,DD1,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICKCAV (EL,DK1,X,k)
       CALL DRIFT(D2,DD2,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICKCAV (EL,DK2,X,k)

       CALL DRIFT(D2,DD2,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICKCAV (EL,DK1,X,k)
       CALL DRIFT(D1,DD1,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)



    CASE(6)
       DO I =1,4
          DF(I)=EL%L*YOSD(I)/EL%P%NST
          DDF(I)=EL%P%LD*YOSD(I)/EL%P%NST
          DK(I)=EL%L*YOSK(I)/EL%P%NST
       ENDDO

       !       DO I=1,B%N

       !        X=BEAM_IN_X(B,I)
       DO J=4,2,-1
          CALL DRIFT(DF(J),DDF(J),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICKCAV (EL,DK(J),X,k)
       ENDDO
       CALL DRIFT(DF(1),DDF(1),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICKCAV (EL,DK(1),X,k)

       CALL DRIFT(DF(1),DDF(1),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       DO J=2,4
          CALL KICKCAV(EL,DK(J),X,k)
          CALL DRIFT(DF(J),DDF(J),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       ENDDO




    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

    k%TOTALPATH=TOTALPATH_FLAG


  END SUBROUTINE INTER_CAV4

  SUBROUTINE INTEP_CAV4(EL,X,kt)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) ::  X(6)

    TYPE(CAV4P),INTENT(INOUT):: EL
    real(dp) DD
    real(dp) DD1,DD2
    real(dp) DDF(4)
    TYPE(REAL_8) DH,D,D1,D2,DK1,DK2,DF(4),DK(4)
    INTEGER I,J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    TYPE(INTERNAL_STATE) kt !,OPTIONAL :: K

    IF(EL%THIN) return
    k=kt
    TOTALPATH_FLAG=k%TOTALPATH
    k%TOTALPATH=el%CAVITY_TOTALPATH



    SELECT CASE(EL%P%METHOD)
    CASE(2)
       CALL ALLOC(DH,D)

       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       DD=EL%P%LD/2.0_dp/EL%P%NST

       !       DO I=1,B%N

       !        X=BEAM_IN_X(B,I)
       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICKCAV (EL,D,X,k)
       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)

       CALL KILL(DH,D)

    CASE(4)
       CALL ALLOC(D1,D2,DK1,DK2)
       D1=EL%L*FD1/EL%P%NST
       D2=EL%L*FD2/EL%P%NST
       DD1=EL%P%LD*FD1/EL%P%NST
       DD2=EL%P%LD*FD2/EL%P%NST
       DK1=EL%L*FK1/EL%P%NST
       DK2=EL%L*FK2/EL%P%NST

       !       DO I=1,B%N

       !        X=BEAM_IN_X(B,I)
       CALL DRIFT(D1,DD1,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICKCAV (EL,DK1,X,k)
       CALL DRIFT(D2,DD2,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICKCAV (EL,DK2,X,k)

       CALL DRIFT(D2,DD2,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICKCAV (EL,DK1,X,k)
       CALL DRIFT(D1,DD1,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)

       CALL KILL(D1,D2,DK1,DK2)


    CASE(6)
       CALL ALLOC(DF,4);CALL ALLOC(DK,4);
       DO I =1,4
          DF(I)=EL%L*YOSD(I)/EL%P%NST
          DDF(I)=EL%P%LD*YOSD(I)/EL%P%NST
          DK(I)=EL%L*YOSK(I)/EL%P%NST
       ENDDO

       !       DO I=1,B%N

       !        X=BEAM_IN_X(B,I)
       DO J=4,2,-1
          CALL DRIFT(DF(J),DDF(J),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICKCAV (EL,DK(J),X,k)
       ENDDO
       CALL DRIFT(DF(1),DDF(1),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICKCAV (EL,DK(1),X,k)

       CALL DRIFT(DF(1),DDF(1),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       DO J=2,4
          CALL KICKCAV(EL,DK(J),X,k)
          CALL DRIFT(DF(J),DDF(J),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       ENDDO


       CALL KILL(DF,4);CALL KILL(DK,4);


    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

    k%TOTALPATH=TOTALPATH_FLAG


  END SUBROUTINE INTEP_CAV4

  
  SUBROUTINE track_slice4p(EL,X,kt,zi)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) ::  X(6)
    integer zi
    TYPE(REAL_8) z
    TYPE(CAV4P),INTENT(INOUT):: EL
    TYPE(INTERNAL_STATE) kt !,OPTIONAL :: K
   
    if(el%n_bessel/=-1) then
     call INTEP_CAV4(EL,X,kt)
    else
     call INTEP_CAVbmad4(EL,X,kt,zi)
    endif    
  end SUBROUTINE track_slice4p



  SUBROUTINE CAVER(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(CAV4),INTENT(INOUT):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ADJUST_TIME_CAV4(EL,X,k,1)
!    IF(EL%N_BESSEL>0)
 CALL FRINGECAV(EL,X,k,1)

    !    TOTALPATH_FLAG=k%TOTALPATH
    !    k%TOTALPATH=CAVITY_TOTALPATH

    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    DO I=1,EL%P%NST
       IF(.NOT.PRESENT(MID)) call track_slice(EL,X,k,i)
       IF(PRESENT(MID)) CALL XMID(MID,X,I)
    ENDDO

    !    k%TOTALPATH=TOTALPATH_FLAG

!    IF(EL%N_BESSEL>0)
 CALL FRINGECAV(EL,X,k,2)
    CALL ADJUST_TIME_CAV4(EL,X,k,2)


  END SUBROUTINE CAVER

    SUBROUTINE check_symplectic_bmad_cavity(f,norm,met,nst,kmax,turn_off_tpsa)
    IMPLICIT NONE
    TYPE(fibre),target:: f
    TYPE(CAV4P),pointer:: EL
    logical(lp),optional :: turn_off_tpsa
     logical(lp) tpsa
    real(dp) norm,symplectic_check_l
    integer met,nst,nthin,met0,nst0,kmax

!  INTEGER :: metcav=0, nstcav=0
!  real(dp) :: xcav(1:6)=0.001d0, symplectic_check=1.d-10
!  logical(lp) :: switch_to_fake=.true.
  
    type(damap) m
    type(real_8) y(6)
!   integer :: limit_int0(2) =(/4,18/)
    integer :: nlim(1:6) =(/0,1,0,3,0,7/)  ! multiplicative factors  
    integer :: nlimit(1:4) , k


     if(symplectic_check==0.0_dp) then
       if(metcav>0.and.nstcav>0) then
         met=metcav
         nst=nstcav
        else
         met=el%p%method
         nst=el%p%nst        
       endif
       return
     endif
     symplectic_check_l=abs(symplectic_check)

     nlimit=0
     nlimit(1)=0
     nlimit(2)=1*limit_int0(1)
     nlimit(4)=3*limit_int0(2)   
     
    EL=>f%magp%c4
    EL%P%CHARGE=>f%charge
    EL%P%dir=>f%dir
    tpsa=my_true
       if(present(turn_off_tpsa)) tpsa=.not.turn_off_tpsa
    met0=el%p%method
    nst0=el%p%nst
    if(el%n_bessel/=-1) then
     write(6,*) " this is not a BMAD cavity "
     stop 
    endif

     if(tpsa) call init(default0,1,0)
    norm=1.d38
    if(nstcav/=0) then
     met=metcav
     nst=nstcav
     else
     met=2
     nst=2
    endif
     k=0
    do while(norm>=symplectic_check_l.and.k<kmax) 
    call alloc(m)
    call alloc(y)
    m=1
    y=m+xcav
     call CAVEP(el,y,default0)
    m=y
     call checksymp(m,norm)
    call kill(m)
    call kill(y)
    if(nstcav/=0) then
     el%p%method=met0
     el%p%nst=nst0
     return
    endif    
    nst=nst+1
    nthin=nlim(met)*nst
    if(nthin>=nlimit(4)) then
     met=6
     nst=nst/nlim(met)
     if(met<=el%p%method.and.nst<=el%p%nst) then
      nst=el%p%nst+1
      met=el%p%method
     endif
    elseif(nthin>=nlimit(2)) then
     met=4
     nst=nst/nlim(met)
     if(met<=el%p%method.and.nst<=el%p%nst) then
      nst=el%p%nst+1
      met=el%p%method
     endif
    else
     met=2
     if(met<=el%p%method.and.nst<=el%p%nst) then
      nst=el%p%nst+1
      met=el%p%method
     endif
    endif
     k=k+1
     if(symplectic_check<0) write(6,*) k,norm,met,nst
    el%p%method=met
    el%p%nst=nst
    enddo
    el%p%method=met0
    el%p%nst=nst0
    end SUBROUTINE check_symplectic_bmad_cavity  
 
  SUBROUTINE CAVEP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    ! TYPE(WORM_8),OPTIONAL,INTENT(INOUT):: MID
    TYPE(CAV4P),INTENT(INOUT):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    CALL ADJUST_TIME_CAV4(EL,X,k,1)
   ! IF(EL%N_BESSEL>0) 
CALL FRINGECAV(EL,X,k,1)
    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    !   TOTALPATH_FLAG=k%TOTALPATH
    !   k%TOTALPATH=CAVITY_TOTALPATH

    DO I=1,EL%P%NST
       call track_slice(EL,X,k,i)
       !          IF(PRESENT(MID)) CALL XMID(MID,X,I)
    ENDDO

    !    k%TOTALPATH=TOTALPATH_FLAG

  !  IF(EL%N_BESSEL>0) 
CALL FRINGECAV(EL,X,k,2)
    CALL ADJUST_TIME_CAV4(EL,X,k,2)


  END SUBROUTINE CAVEP

  SUBROUTINE CAVITYR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(CAV4),INTENT(INOUT):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) O,X1,X3,BBYTWT,BBYTW,BBXTW
    integer j,ko
    real(dp) dir
    IF(k%NOCAVITY.and.(.not.EL%always_on)) RETURN
    IF(PRESENT(MID)) CALL XMID(MID,X,0)
    !    EL%DELTA_E=x(5)
    IF(.NOT.PRESENT(MID)) then
       dir=EL%P%DIR*EL%P%CHARGE
       O=twopi*EL%freq/CLIGHT

       do ko=1,el%nf

          x(5)=x(5)-el%f(ko)*dir*EL%volt*volt_c*SIN(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO) &
               +EL%phase0)/EL%P%P0C
          ! doing crabola

          X1=X(1)
          X3=X(3)


          IF(EL%P%NMUL>=1) THEN
             BBYTW=EL%BN(EL%P%NMUL)
             BBXTW=EL%AN(EL%P%NMUL)

             DO  J=EL%P%NMUL-1,1,-1
                BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
                BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
                BBYTW=BBYTWT
             ENDDO
          ELSE
             BBYTW=0.0_dp
             BBXTW=0.0_dp
          ENDIF

          ! multipole * cos(omega t+ phi)/p0c

          X(2)=X(2)-el%f(ko)*dir*BBYTW/EL%P%P0C*(el%a+ el%r*cos(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0))
          X(4)=X(4)+el%f(ko)*DIR*BBXTW/EL%P%P0C*(el%a+ el%r*cos(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0))

          IF(EL%P%NMUL>=1) THEN
             BBYTW=-EL%BN(EL%P%NMUL)/EL%P%NMUL
             BBXTW=-EL%AN(EL%P%NMUL)/EL%P%NMUL


             DO  J=EL%P%NMUL,2,-1
                BBYTWT=X1*BBYTW-X3*BBXTW-EL%BN(J-1)/(J-1)
                BBXTW=X3*BBYTW+X1*BBXTW-EL%AN(J-1)/(J-1)
                BBYTW=BBYTWT
             ENDDO
             BBYTWT=X1*BBYTW-X3*BBXTW
             BBXTW=X3*BBYTW+X1*BBXTW
             BBYTW=BBYTWT
          ELSE
             BBYTW=0.0_dp
             BBXTW=0.0_dp
          ENDIF
          X(5)=X(5)+el%f(ko)*ko*O*dir*BBYTW/EL%P%P0C*el%r*sin(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)

       enddo
    endif

    IF(PRESENT(MID)) CALL XMID(MID,X,1)
    !          IF(.NOT.PRESENT(MID)) x(5)=x(5)-HALF*EL%P%DIR*EL%P%CHARGE*EL%volt*c_1d_3*SIN(twopi*EL%freq*x(6)/CLIGHT+EL%PHAS+EL%phase0)/EL%P%P0C
    !    EL%DELTA_E=(X(5)-EL%DELTA_E)*EL%P%P0C
    IF(PRESENT(MID)) CALL XMID(MID,X,1)

  END SUBROUTINE CAVITYR

  SUBROUTINE CAVITYP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    ! TYPE(WORM_8),OPTIONAL,INTENT(INOUT):: MID
    TYPE(CAV4P),INTENT(INOUT):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    type(real_8) O,X1,X3,BBYTWT,BBYTW,BBXTW
    INTEGER J,ko
    real(dp) dir
    IF(k%NOCAVITY.and.(.not.EL%always_on)) RETURN
    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)
    !    EL%DELTA_E=x(5)
    call alloc(BBYTWT,BBXTW,BBYTW,x1,x3,O)
    dir=EL%P%DIR*EL%P%CHARGE
    O=twopi*EL%freq/CLIGHT

    do ko=1,el%nf

       x(5)=x(5)-el%f(ko)*dir*EL%volt*volt_c*SIN(ko*O*(x(6)+EL%t)+EL%PHAS+ &
            EL%PH(KO)+EL%phase0)/EL%P%P0C
       ! doing crabola

       X1=X(1)
       X3=X(3)


       IF(EL%P%NMUL>=1) THEN
          BBYTW=EL%BN(EL%P%NMUL)
          BBXTW=EL%AN(EL%P%NMUL)

          DO  J=EL%P%NMUL-1,1,-1
             BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
             BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
             BBYTW=BBYTWT
          ENDDO
       ELSE
          BBYTW=0.0_dp
          BBXTW=0.0_dp
       ENDIF

       ! multipole * cos(omega t+ phi)/p0c

       ! multipole * cos(omega t+ phi)/p0c

       X(2)=X(2)-el%f(ko)*dir*BBYTW/EL%P%P0C*(el%a+ el%r*cos(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0))
       X(4)=X(4)+el%f(ko)*DIR*BBXTW/EL%P%P0C*(el%a+ el%r*cos(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0))

       IF(EL%P%NMUL>=1) THEN
          BBYTW=-EL%BN(EL%P%NMUL)/EL%P%NMUL
          BBXTW=-EL%AN(EL%P%NMUL)/EL%P%NMUL


          DO  J=EL%P%NMUL,2,-1
             BBYTWT=X1*BBYTW-X3*BBXTW-EL%BN(J-1)/(J-1)
             BBXTW=X3*BBYTW+X1*BBXTW-EL%AN(J-1)/(J-1)
             BBYTW=BBYTWT
          ENDDO
          BBYTWT=X1*BBYTW-X3*BBXTW
          BBXTW=X3*BBYTW+X1*BBXTW
          BBYTW=BBYTWT
       ELSE
          BBYTW=0.0_dp
          BBXTW=0.0_dp
       ENDIF
       X(5)=X(5)+el%f(ko)*ko*O*dir*BBYTW/EL%P%P0C*el%r*sin(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)

    enddo

    call KILL(BBYTWT,BBXTW,BBYTW,x1,x3,O)
  END SUBROUTINE CAVITYP
!!!!! Saga stuff !!!!!
  SUBROUTINE Abmad_TRANSR(EL,Z,X,k,A,AD,B,E)    ! EXP(-I:(X^2+Y^2)/2*A_TRANS:)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(INOUT):: Z,A(3),AD(2)
    real(dp),optional,INTENT(INOUT)::B(3),E(3)
    TYPE(CAV4),INTENT(INOUT):: EL
    real(dp) C1,S1,V,O,dad1dz
     INTEGER KO
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    if(el%N_BESSEL/=-1) return
    IF(k%NOCAVITY.and.(.not.EL%always_on)) RETURN
    IF(EL%THIN) RETURN


    O=EL%freq*twopi/CLIGHT
    V=EL%P%CHARGE*EL%volt*volt_c/EL%P%P0C

    A=0.0_dp
    ad=0.0_dp
    dad1dz=0.0_dp
   do ko=1,el%nf    ! over modes
   
    C1=el%f(ko)*V*sin(ko*O*z)*COS(ko*O*(x(6)+EL%t)+EL%PHAS+EL%phase0+EL%PH(KO))*0.5_dp
    S1=el%f(ko)*(ko*O)*V*sin(ko*O*z)*SIN(ko*O*(x(6)+EL%t)+EL%PHAS+EL%phase0+EL%PH(KO))/2.0_dp
    AD(1)=-C1+AD(1)
    AD(2)=S1+AD(2)
    dad1dz=dad1dz-(ko*O)*el%f(ko)*V*cos(ko*O*z)*COS(ko*O*(x(6)+EL%t)+EL%PHAS+EL%phase0+EL%PH(KO))*0.5_dp

!!!   DA_3/DT FOR KICK IN X(5)    
    A(3)=A(3)-EL%P%DIR*el%f(ko)*V*COS(ko*O*z)*SIN(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)
   enddo

    A(1)=AD(1)*X(1)  ! A_x
    A(2)=AD(1)*X(3)  ! A_y

     if(present(b)) then
     b(1)=-dad1dz*x(3)/EL%P%CHARGE
     b(2)= dad1dz*x(1)/EL%P%CHARGE
     b(3)=0.0_dp
    endif

    if(present(e)) then
     E(1)=-dad1dz*x(3)/EL%P%CHARGE
     E(2)= dad1dz*x(1)/EL%P%CHARGE
     E(3)=A(3)/EL%P%CHARGE
    endif

  END SUBROUTINE Abmad_TRANSR

 SUBROUTINE Abmad_TRANSP(EL,Z,X,k,A,AD,B,E)    ! EXP(-I:(X^2+Y^2)/2*A_TRANS:)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(INOUT):: Z,A(3),AD(2)
    TYPE(CAV4P),INTENT(INOUT):: EL
    TYPE(REAL_8),optional,INTENT(INOUT):: B(3),E(3)
    TYPE(REAL_8) C1,S1,V,O,dad1dz
     INTEGER KO
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    if(el%N_BESSEL/=-1) return
    IF(k%NOCAVITY.and.(.not.EL%always_on)) RETURN
    IF(EL%THIN) RETURN
    
    CALL ALLOC(C1,S1,V,O,dad1dz)

    O=EL%freq*twopi/CLIGHT
    V=EL%P%CHARGE*EL%volt*volt_c/EL%P%P0C
    
    DO KO=1,3
     A(KO)=0.0_dp
    ENDDO
    DO KO=1,2
     AD(KO)=0.0_dp
    ENDDO

    dad1dz=0.0_dp

   do ko=1,el%nf    ! over modes
   
    C1=el%f(ko)*V*sin(ko*O*z)*COS(ko*O*(x(6)+EL%t)+EL%PHAS+EL%phase0+EL%PH(KO))*0.5_dp
    S1=el%f(ko)*(ko*O)*V*sin(ko*O*z)*SIN(ko*O*(x(6)+EL%t)+EL%PHAS+EL%phase0+EL%PH(KO))/2.0_dp

    AD(1)=-C1+AD(1)
    AD(2)=S1+AD(2)

    dad1dz=dad1dz-(ko*O)*el%f(ko)*V*cos(ko*O*z)*COS(ko*O*(x(6)+EL%t)+EL%PHAS+EL%phase0+EL%PH(KO))*0.5_dp

!!!   DA_3/DT FOR KICK IN X(5)    
    A(3)=A(3)-EL%P%DIR*el%f(ko)*V*COS(ko*O*z)*SIN(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)
   enddo

    A(1)=AD(1)*X(1)
    A(2)=AD(1)*X(3)
 
     if(present(b)) then
     b(1)=-dad1dz*x(3)/EL%P%CHARGE
     b(2)= dad1dz*x(1)/EL%P%CHARGE
     b(3)=0.0_dp
    endif

    if(present(e)) then
     E(1)=-dad1dz*x(3)/EL%P%CHARGE
     E(2)= dad1dz*x(1)/EL%P%CHARGE
     E(3)=A(3)/EL%P%CHARGE
    endif

    CALL KILL(C1,S1,V,O,dad1dz)


  END SUBROUTINE Abmad_TRANSP

  subroutine feval_CAV_bmadr(Z0,X,k,f,D)   ! MODELLED BASED ON DRIFT
    IMPLICIT NONE
    real(dp), INTENT(INout) :: X(6)
    real(dp),INTENT(INOUT):: Z0
    real(dp), INTENT(INOUT) :: F(6)
    REAL(DP) A(3),AD(2),PZ
    TYPE(CAV4),  INTENT(INOUT) :: D
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    CALL Abmad_TRANS(D,Z0,X,k,A,AD)

    X(2)=X(2)-A(1)
    X(4)=X(4)-A(2)

    IF(D%P%EXACT) THEN
       if(k%TIME) then
          PZ=ROOT(1.0_dp+2.0_dp*X(5)/D%P%BETA0+x(5)**2-X(2)**2-X(4)**2)
          F(1)=X(2)/PZ
          F(3)=X(4)/PZ
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=(1.0_dp/D%P%BETA0+X(5))/PZ-(1-k%TOTALPATH)/D%P%BETA0
       else
          PZ=ROOT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          F(1)=X(2)/PZ
          F(3)=X(4)/PZ
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=(1.0_dp+X(5))/PZ-(1-k%TOTALPATH)
       endif
    ELSE
       if(k%TIME) then
          PZ=ROOT(1.0_dp+2.0_dp*X(5)/D%P%BETA0+x(5)**2)
          F(1)=X(2)/PZ
          F(3)=X(4)/PZ
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=((X(2)*X(2)+X(4)*X(4))/2.0_dp/pz**2+1.0_dp)*(1.0_dp/D%P%BETA0+x(5))/pz
          F(6)=F(6)-(1-k%TOTALPATH)/D%P%BETA0
       else
          F(1)=X(2)/(1.0_dp+X(5))
          F(3)=X(4)/(1.0_dp+X(5))
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=(1.0_dp/(1.0_dp+X(5)))*(X(2)*X(2)+X(4)*X(4))/2.0_dp/(1.0_dp+X(5))+k%TOTALPATH
       endif
    ENDIF

    X(2)=X(2)+A(1)
    X(4)=X(4)+A(2)

  END subroutine feval_CAV_bmadr


  subroutine feval_CAV_bmadp(Z0,X,k,f,D)   ! MODELLED BASED ON DRIFT
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INout) :: X(6)
    TYPE(REAL_8),INTENT(INOUT):: Z0
    TYPE(REAL_8), INTENT(INOUT) :: F(6)
    TYPE(REAL_8)  A(3),AD(2),PZ
    TYPE(CAV4P),  INTENT(INOUT) :: D
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    call alloc(A,3)
    call alloc(AD,2)
    call alloc(PZ)

    CALL Abmad_TRANS(D,Z0,X,k,A,AD)

    X(2)=X(2)-A(1)
    X(4)=X(4)-A(2)

    IF(D%P%EXACT) THEN
       if(k%TIME) then
          PZ=sqrt(1.0_dp+2.0_dp*X(5)/D%P%BETA0+x(5)**2-X(2)**2-X(4)**2)
          F(1)=X(2)/PZ
          F(3)=X(4)/PZ
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=(1.0_dp/D%P%BETA0+X(5))/PZ-(1-k%TOTALPATH)/D%P%BETA0
       else
          PZ=sqrt((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          F(1)=X(2)/PZ
          F(3)=X(4)/PZ
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=(1.0_dp+X(5))/PZ-(1-k%TOTALPATH)
       endif
    ELSE
       if(k%TIME) then
          PZ=sqrt(1.0_dp+2.0_dp*X(5)/D%P%BETA0+x(5)**2)
          F(1)=X(2)/PZ
          F(3)=X(4)/PZ
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=((X(2)*X(2)+X(4)*X(4))/2.0_dp/pz**2+1.0_dp)*(1.0_dp/D%P%BETA0+x(5))/pz
          F(6)=F(6)-(1-k%TOTALPATH)/D%P%BETA0
       else
          F(1)=X(2)/(1.0_dp+X(5))
          F(3)=X(4)/(1.0_dp+X(5))
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=(1.0_dp/(1.0_dp+X(5)))*(X(2)*X(2)+X(4)*X(4))/2.0_dp/(1.0_dp+X(5))+k%TOTALPATH
       endif
    ENDIF

    X(2)=X(2)+A(1)
    X(4)=X(4)+A(2)

    call KILL(A,3)
    call KILL(AD,2)
    call KILL(PZ)
  END subroutine feval_CAV_bmadp

 subroutine rk2bmad_cavr(ti,h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    real(dp), INTENT(INOUT)::  y(ne)
    real(dp)  yt(ne),f(ne),a(ne),b(ne)
    real(dp)  tt
    type (cav4) ,INTENT(INOUT)::  GR
    integer j
    real(dp), intent(inout) :: ti,h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    call feval_CAV_bmad(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    tt=tI+h/2.0_dp
    call feval_CAV_bmad(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+b(j)
    enddo
    tI=ti+h

    return
  end  subroutine rk2bmad_cavr

 subroutine rk4bmad_cavr(ti,h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    real(dp), INTENT(INOUT)::  y(ne)
    real(dp)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne)
    type (CAV4) ,INTENT(INOUT)::  GR
    integer j
    real(dp), intent(inout) :: h
    real(dp), intent(inout) :: ti
    real(dp) TT
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    call feval_CAV_bmad(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    tt=tI+h/2.0_dp
    call feval_CAV_bmad(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + b(j)/2.0_dp
    enddo


    !      tt=tI+1
    call feval_CAV_bmad(tt,yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+c(j)
    enddo

    tt=tI+h
    call feval_CAV_bmad(tt,yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo


    do  j=1,ne
       y(j) = y(j)+(a(j)+2.0_dp*b(j)+2.0_dp*c(j)+d(j))/6.0_dp
    enddo
    tI=tt

    return
  end  subroutine rk4bmad_cavr

 subroutine rk6bmad_cavr(ti,h,GR,y,k)
    IMPLICIT none
    !  Written by Rob Ryne, Spring 1986, based on a routine of
    !c  J. Milutinovic.
    !c  For a reference, see page 76 of F. Ceschino and J Kuntzmann,
    !c  Numerical Solution of Initial Value Problems, Prentice Hall 1966.
    !c  This integration routine makes local truncation errors at each
    !c  step of order h**7.
    !c  That is, it is locally correct through terms of order h**6.
    !c  Each step requires 8 function evaluations.

    integer ne
    parameter (ne=6)
    real(dp), INTENT(INOUT)::  y(ne)
    real(dp)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne),e(ne),g(ne),o(ne),p(ne)
    real(dp)  tt
    type (CAV4) ,INTENT(INOUT)::  GR
    integer j
    real(dp), intent(inout) :: ti,h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    call feval_CAV_bmad(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/9.0_dp
    enddo
    tt=tI+h/9.0_dp
    call feval_CAV_bmad(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + (a(j) + 3.0_dp*b(j))/24.0_dp
    enddo
    tt=tI+h/6.0_dp
    call feval_CAV_bmad(tt,yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j)+(a(j)-3.0_dp*b(j)+4.0_dp*c(j))/6.0_dp
    enddo

    tt=tI+h/3.0_dp
    call feval_CAV_bmad(tt,yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j) + (-5.0_dp*a(j) + 27.0_dp*b(j) - 24.0_dp*c(j) + 6.0_dp*d(j))/8.0_dp
    enddo
    tt=tI+0.5_dp*h
    call feval_CAV_bmad(tt,yt,k,f,gr)
    do  j=1,ne
       e(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j) + (221.0_dp*a(j) - 981.0_dp*b(j) + 867.0_dp*c(j)- 102.0_dp*d(j) + e(j))/9.0_dp
    enddo
    tt = tI+2.0_dp*h/3.0_dp
    call feval_CAV_bmad(tt,yt,k,f,gr)
    do   j=1,ne
       g(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j) = y(j)+(-183.0_dp*a(j)+678.0_dp*b(j)-472.0_dp*c(j)-66.0_dp*d(j)+80.0_dp*e(j) + 3.0_dp*g(j))/48.0_dp
    enddo
    tt = tI + 5.0_dp*h/6.0_dp
    call feval_CAV_bmad(tt,yt,k,f,gr)
    do  j=1,ne
       o(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j) = y(j)+(716.0_dp*a(j)-2079.0_dp*b(j)+1002.0_dp*c(j)+834.0_dp*d(j)-454.0_dp*e(j)-9.0_dp*g(j)+72.0_dp*o(j))/82.0_dp
    enddo

    tt = tI + h
    call feval_CAV_bmad(tt,yt,k,f,gr)
    do  j=1,ne
       p(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+(41.0_dp*a(j)+216.0_dp*c(j)+27.0_dp*d(j)+272.0_dp*e(j)+27.0_dp*g(j)+216.0_dp*o(j)+41.0_dp*p(j))/840.0_dp
    enddo
    tI=ti+h

    return
  end  subroutine rk6bmad_cavr

  subroutine rk2bmad_cavp(ti,h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    type (real_8), INTENT(INOUT)::  y(ne)
    type (real_8)  yt(ne),f(ne),a(ne),b(ne)
    type (real_8)  tt
    type (cav4p) ,INTENT(INOUT)::  GR
    integer j
    type(real_8), intent(inout) :: ti,h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    call alloc(yt,ne)
    call alloc(f,ne)
    call alloc(a,ne)
    call alloc(b,ne)

    call alloc(tt)

    call feval_CAV_bmad(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    tt=tI+h/2.0_dp
    call feval_CAV_bmad(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+b(j)
    enddo
    tI=ti+h

    call kill(tt)
    call kill(yt,ne)
    call kill(f,ne)
    call kill(a,ne)
    call kill(b,ne)

    return
  end  subroutine rk2bmad_cavp

  subroutine rk4bmad_cavp(ti,h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    type(real_8), INTENT(INOUT)::  y(ne)
    type (CAV4p) ,INTENT(INOUT)::  GR
    type(real_8), intent(inout) :: h
    type(real_8), intent(inout) :: ti
    type(real_8)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne)
    type(real_8) TT
    integer j
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    call alloc(tt)
    call alloc(yt)
    call alloc(f)
    call alloc(a)
    call alloc(b)
    call alloc(c)
    call alloc(d)

    call feval_CAV_bmad(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    tt=tI+h/2.0_dp
    call feval_CAV_bmad(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + b(j)/2.0_dp
    enddo


    !      tt=tI+1
    call feval_CAV_bmad(tt,yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+c(j)
    enddo

    tt=tI+h
    call feval_CAV_bmad(tt,yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo


    do  j=1,ne
       y(j) = y(j)+(a(j)+2.0_dp*b(j)+2.0_dp*c(j)+d(j))/6.0_dp
    enddo
    tI=tt

    call kill(tt)
    call kill(yt)
    call kill(f)
    call kill(a)
    call kill(b)
    call kill(c)
    call kill(d)

    return
  end  subroutine rk4bmad_cavp

  ! sixth order Runge
  subroutine rk6bmad_cavp(ti,h,GR,y,k)
    IMPLICIT none


    integer ne
    parameter (ne=6)
    type (real_8), INTENT(INOUT)::  y(ne)
    type (real_8)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne),e(ne),g(ne),o(ne),p(ne)
    type (real_8)  tt
    type (cav4p) ,INTENT(INOUT)::  GR
    integer j
    type(real_8), intent(inout) :: ti,h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    call alloc(yt,ne)
    call alloc(f,ne)
    call alloc(a,ne)
    call alloc(b,ne)
    call alloc(c,ne)
    call alloc(d,ne)
    call alloc(e,ne)
    call alloc(g,ne)
    call alloc(o,ne)
    call alloc(p,ne)
    call alloc(tt)

    call feval_CAV_bmad(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/9.0_dp
    enddo
    tt=tI+h/9.0_dp
    call feval_CAV_bmad(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + (a(j) + 3.0_dp*b(j))/24.0_dp
    enddo
    tt=tI+h/6.0_dp
    call feval_CAV_bmad(tt,yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j)+(a(j)-3.0_dp*b(j)+4.0_dp*c(j))/6.0_dp
    enddo

    tt=tI+h/3.0_dp
    call feval_CAV_bmad(tt,yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j) + (-5.0_dp*a(j) + 27.0_dp*b(j) - 24.0_dp*c(j) + 6.0_dp*d(j))/8.0_dp
    enddo
    tt=tI+0.5_dp*h
    call feval_CAV_bmad(tt,yt,k,f,gr)
    do  j=1,ne
       e(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j) + (221.0_dp*a(j) - 981.0_dp*b(j) + 867.0_dp*c(j)- 102.0_dp*d(j) + e(j))/9.0_dp
    enddo
    tt = tI+2.0_dp*h/3.0_dp
    call feval_CAV_bmad(tt,yt,k,f,gr)
    do   j=1,ne
       g(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j) = y(j)+(-183.0_dp*a(j)+678.0_dp*b(j)-472.0_dp*c(j)-66.0_dp*d(j)+80.0_dp*e(j) + 3.0_dp*g(j))/48.0_dp
    enddo
    tt = tI + 5.0_dp*h/6.0_dp
    call feval_CAV_bmad(tt,yt,k,f,gr)
    do  j=1,ne
       o(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j) = y(j)+(716.0_dp*a(j)-2079.0_dp*b(j)+1002.0_dp*c(j)+834.0_dp*d(j)-454.0_dp*e(j)-9.0_dp*g(j)+72.0_dp*o(j))/82.0_dp
    enddo

    tt = tI + h
    call feval_CAV_bmad(tt,yt,k,f,gr)
    do  j=1,ne
       p(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+(41.0_dp*a(j)+216.0_dp*c(j)+27.0_dp*d(j)+272.0_dp*e(j)+27.0_dp*g(j)+216.0_dp*o(j)+41.0_dp*p(j))/840.0_dp
    enddo
    tI=ti+h
    call kill(tt)
    call kill(yt,ne)
    call kill(f,ne)
    call kill(a,ne)
    call kill(b,ne)
    call kill(c,ne)
    call kill(d,ne)
    call kill(e,ne)
    call kill(g,ne)
    call kill(o,ne)
    call kill(p,ne)

    return
  end  subroutine rk6bmad_cavp

  SUBROUTINE INTER_CAVbmad4(EL,X,kt,j)
    IMPLICIT NONE
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(CAV4),INTENT(INOUT):: EL

    integer , INTENT(IN) :: j
    real(dp) D1
    REAL(DP) Z0
    INTEGER TOTALPATH
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    TYPE(INTERNAL_STATE) kt !,OPTIONAL :: K

    D1=el%p%dir*EL%L/EL%P%NST
    IF(EL%P%DIR==1) THEN
       Z0=(j-1)*d1
    ELSE
       Z0=EL%L+(j-1)*d1
    ENDIF

    k=kt
    TOTALPATH=k%TOTALPATH
    k%TOTALPATH=1
    SELECT CASE(EL%P%METHOD)
    CASE(2)

       call rk2_cav(z0,d1,el,X,k)

    CASE(4)

       call rk4_cav(z0,d1,el,X,k)

    CASE(6)

       call rk6_cav(z0,d1,el,X,k)
    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

    !    IF(k%FRINGE)

    k%TOTALPATH=TOTALPATH

  END SUBROUTINE INTER_CAVbmad4

  SUBROUTINE INTEP_CAVbmad4(EL,X,kt,j)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(CAV4P),INTENT(INOUT):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    TYPE(INTERNAL_STATE) kt !,OPTIONAL :: K

    !    TYPE(REAL_8), INTENT(IN) :: Z
    integer, INTENT(IN) :: j
    TYPE(REAL_8) Z0,D1
    INTEGER TOTALPATH
    real(dp) xx(6)

    CALL ALLOC(Z0,D1)

    D1=el%p%dir*EL%L/EL%P%NST
    IF(EL%P%DIR==1) THEN
       Z0=(j-1)*d1
    ELSE
       Z0=EL%L+(j-1)*d1
    ENDIF
    k=kt
    TOTALPATH=k%TOTALPATH
    k%TOTALPATH=1

    SELECT CASE(EL%P%METHOD)
    CASE(2)

       call rk2_cav(z0,d1,el,X,k)

    CASE(4)

       call rk4_cav(z0,d1,el,X,k)

    CASE(6)

       call rk6_cav(z0,d1,el,X,k)

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

    !    IF(k%FRINGE)

    k%TOTALPATH=TOTALPATH

    CALL KILL(Z0,D1)


  END SUBROUTINE INTEP_CAVbmad4



  SUBROUTINE FRINGECAVR(EL,X,k,J)
    IMPLICIT NONE
    REAL(DP), INTENT(INOUT) ::  X(6)
    TYPE(CAV4),INTENT(INOUT):: EL
    integer,INTENT(IN):: J
    integer JC,ko
    REAL(DP) C1,S1,V,O,z
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    REAL(DP) KBMAD 
    !return
    !  As of June 2007, Etienne believes that the fringe approximately cancels
    ! it is a mystery perhaps due to the use of canonical variables.
    ! as of 2012 David Sagan said that this is needed after all

    JC=-2*J+3
    if(jc==1) then
     z=0.0_dp
    else
     z=EL%L
    endif

    IF(k%NOCAVITY.and.(.not.EL%always_on)) RETURN
    IF(.NOT.(k%FRINGE.or.EL%P%permfringe/=0.or.el%N_BESSEL==-1)) RETURN  ! 2012 forcing fringes if n_bessel > 0
    IF(EL%THIN) RETURN
    IF(jC==1.AND.EL%P%KILL_ENT_FRINGE) RETURN
    IF(jC==-1.AND.EL%P%KILL_EXI_FRINGE) RETURN
    IF(el%N_BESSEL==-1) THEN
     KBMAD=1
    ELSE
     KBMAD=0 
    ENDIF

       

    O=EL%freq*twopi/CLIGHT
    V=jC*EL%P%CHARGE*EL%volt*volt_c/EL%P%P0C


   do ko=1,el%nf    ! over modes
   
    s1=cos(kbmad*ko*O*z)*sin(ko*O*(x(6)+EL%t)+EL%PHAS+EL%phase0+EL%PH(KO))
    c1=cos(kbmad*ko*O*z)*cos(ko*O*(x(6)+EL%t)+EL%PHAS+EL%phase0+EL%PH(KO))


    X(2)=X(2)+V*S1*X(1)*0.5_dp
    X(4)=X(4)+V*S1*X(3)*0.5_dp
    x(5)=x(5)-0.25e0_dp*(X(1)**2+X(3)**2)*V*C1*O*ko

   enddo
  END SUBROUTINE FRINGECAVR

  SUBROUTINE FRINGECAVP(EL,X,k,J)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) ::  X(6)
    TYPE(CAV4P),INTENT(INOUT):: EL
    integer,INTENT(IN):: J
    integer JC,ko
    TYPE(REAL_8) C1,S1,V,O,z
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    REAL(DP) KBMAD 
    !return
    !  As of June 2007, Etienne believes that the fringe approximately cancels
    ! it is a mystery perhaps due to the use of canonical variables.
    ! as of 2012 David Sagan said that this is needed after all
    CALL ALLOC(C1,S1,V,O,z)
    
 
    JC=-2*J+3
    if(jc==1) then
     z=0.0_dp
    else
     z=EL%L
    endif

    IF(k%NOCAVITY.and.(.not.EL%always_on)) RETURN
    IF(.NOT.(k%FRINGE.or.EL%P%permfringe/=0.or.el%N_BESSEL==-1)) RETURN  ! 2012 forcing fringes if n_bessel > 0
    IF(EL%THIN) RETURN
    IF(jC==1.AND.EL%P%KILL_ENT_FRINGE) RETURN
    IF(jC==-1.AND.EL%P%KILL_EXI_FRINGE) RETURN
    IF(el%N_BESSEL==-1) THEN
     KBMAD=1
    ELSE
     KBMAD=0 
    ENDIF

    O=EL%freq*twopi/CLIGHT
    V=jC*EL%P%CHARGE*EL%volt*volt_c/EL%P%P0C

   do ko=1,el%nf    ! over modes
   
    s1=cos(kbmad*ko*O*z)*sin(ko*O*(x(6)+EL%t)+EL%PHAS+EL%phase0+EL%PH(KO))
    c1=cos(kbmad*ko*O*z)*cos(ko*O*(x(6)+EL%t)+EL%PHAS+EL%phase0+EL%PH(KO))


    X(2)=X(2)+V*S1*X(1)*0.5_dp
    X(4)=X(4)+V*S1*X(3)*0.5_dp
    x(5)=x(5)-0.25e0_dp*(X(1)**2+X(3)**2)*V*C1*O*ko

   enddo
    CALL KILL(C1,S1,V,O,z)

  END SUBROUTINE FRINGECAVP





 
  SUBROUTINE KICKCAVR(EL,YL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(INOUT):: YL
    TYPE(CAV4),INTENT(INOUT):: EL
    real(dp) DF,R2,F,DR2,O,VL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) BBYTWT,BBXTW,BBYTW,x1,x3
    integer j,ko
    real(dp) dir

    IF(k%NOCAVITY.and.(.not.EL%always_on)) RETURN

    DIR=EL%P%DIR*EL%P%CHARGE

    O=twopi*EL%freq/CLIGHT
    VL=dir*YL*EL%volt*volt_c/EL%P%P0C

    do ko=1,el%nf    ! over modes

       DF=0.0_dp
       F=1.0_dp
       R2=1.0_dp

       DO I=1,EL%N_BESSEL
          R2=-R2*(ko*O)**2/4.0_dp/(I+1)**2
          DR2=R2*I
          DF=DF+DR2*2
          R2=R2*(X(1)**2+X(3)**2)
          F=F+R2
       ENDDO

       !    EL%DELTA_E=x(5)

       IF(EL%N_BESSEL>0) THEN
          X(2)=X(2)-X(1)*el%f(ko)*DF*VL*COS(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)/(ko*O)
          X(4)=X(4)-X(3)*el%f(ko)*DF*VL*COS(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)/(ko*O)
       ENDIF


       x(5)=x(5)-el%f(ko)*F*VL*SIN(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)


       ! doing crabola


       X1=X(1)
       X3=X(3)


       IF(EL%P%NMUL>=1) THEN
          BBYTW=EL%BN(EL%P%NMUL)
          BBXTW=EL%AN(EL%P%NMUL)

          DO  J=EL%P%NMUL-1,1,-1
             BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
             BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
             BBYTW=BBYTWT
          ENDDO
       ELSE
          BBYTW=0.0_dp
          BBXTW=0.0_dp
       ENDIF

       ! multipole * cos(omega t+ phi)/p0c

       X(2)=X(2)-el%f(ko)*YL*DIR*BBYTW/EL%P%P0C*(EL%A+EL%R*cos(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0))
       X(4)=X(4)+el%f(ko)*YL*DIR*BBXTW/EL%P%P0C*(EL%A+EL%R*cos(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0))

       IF(EL%P%NMUL>=1) THEN
          BBYTW=-EL%BN(EL%P%NMUL)/EL%P%NMUL
          BBXTW=-EL%AN(EL%P%NMUL)/EL%P%NMUL


          DO  J=EL%P%NMUL,2,-1
             BBYTWT=X1*BBYTW-X3*BBXTW-EL%BN(J-1)/(J-1)
             BBXTW=X3*BBYTW+X1*BBXTW-EL%AN(J-1)/(J-1)
             BBYTW=BBYTWT
          ENDDO
          BBYTWT=X1*BBYTW-X3*BBXTW
          BBXTW=X3*BBYTW+X1*BBXTW
          BBYTW=BBYTWT
       ELSE
          BBYTW=0.0_dp
          BBXTW=0.0_dp
       ENDIF

       X(5)=X(5)+el%f(ko)*(ko*O)*YL*DIR*BBYTW/EL%P%P0C*EL%R*sin(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)
    enddo    ! over modes


  END SUBROUTINE KICKCAVR

SUBROUTINE KICKCAVP(EL,YL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6),YL
    TYPE(CAV4P),INTENT(INOUT):: EL
    TYPE(REAL_8) DF,R2,F,DR2,O,VL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    TYPE(REAL_8) BBYTWT,BBXTW,BBYTW,x1,x3
    integer j,ko
    real(dp) dir

    IF(k%NOCAVITY.and.(.not.EL%always_on)) RETURN
    CALL ALLOC(DF,R2,F,DR2,O,VL)
    call alloc(BBYTWT,BBXTW,BBYTW,x1,x3)

    DIR=EL%P%DIR*EL%P%CHARGE

    O=twopi*EL%freq/CLIGHT
    VL=dir*YL*EL%volt*volt_c/EL%P%P0C

    do ko=1,el%nf    ! over modes

       DF=0.0_dp
       F=1.0_dp
       R2=1.0_dp

       DO I=1,EL%N_BESSEL
          R2=-R2*(ko*O)**2/4.0_dp/(I+1)**2
          DR2=R2*I
          DF=DF+DR2*2
          R2=R2*(X(1)**2+X(3)**2)
          F=F+R2
       ENDDO

       !    EL%DELTA_E=x(5)

       IF(EL%N_BESSEL>0) THEN
          X(2)=X(2)-X(1)*el%f(ko)*DF*VL*COS(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)/(ko*O)
          X(4)=X(4)-X(3)*el%f(ko)*DF*VL*COS(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)/(ko*O)
       ENDIF


       x(5)=x(5)-el%f(ko)*F*VL*SIN(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)


       ! doing crabola


       X1=X(1)
       X3=X(3)


       IF(EL%P%NMUL>=1) THEN
          BBYTW=EL%BN(EL%P%NMUL)
          BBXTW=EL%AN(EL%P%NMUL)

          DO  J=EL%P%NMUL-1,1,-1
             BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
             BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
             BBYTW=BBYTWT
          ENDDO
       ELSE
          BBYTW=0.0_dp
          BBXTW=0.0_dp
       ENDIF

       ! multipole * cos(omega t+ phi)/p0c

       X(2)=X(2)-el%f(ko)*YL*DIR*BBYTW/EL%P%P0C*(EL%A+EL%R*cos(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0))
       X(4)=X(4)+el%f(ko)*YL*DIR*BBXTW/EL%P%P0C*(EL%A+EL%R*cos(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0))

       IF(EL%P%NMUL>=1) THEN
          BBYTW=-EL%BN(EL%P%NMUL)/EL%P%NMUL
          BBXTW=-EL%AN(EL%P%NMUL)/EL%P%NMUL


          DO  J=EL%P%NMUL,2,-1
             BBYTWT=X1*BBYTW-X3*BBXTW-EL%BN(J-1)/(J-1)
             BBXTW=X3*BBYTW+X1*BBXTW-EL%AN(J-1)/(J-1)
             BBYTW=BBYTWT
          ENDDO
          BBYTWT=X1*BBYTW-X3*BBXTW
          BBXTW=X3*BBYTW+X1*BBXTW
          BBYTW=BBYTWT
       ELSE
          BBYTW=0.0_dp
          BBXTW=0.0_dp
       ENDIF

       X(5)=X(5)+el%f(ko)*(ko*O)*YL*DIR*BBYTW/EL%P%P0C*EL%R*sin(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)

    enddo    ! over modes
    CALL kill(DF,R2,F,DR2,O,VL)
    call kill(BBYTWT,BBXTW,BBYTW,x1,x3)

  END SUBROUTINE KICKCAVP

  ! STUFF NEEDED FOR INTEGRATION
  SUBROUTINE DRIFTR(L,LD,b,T,EXACT,CTIME,X)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN):: L
    real(dp), INTENT(IN):: LD
    INTEGER,INTENT(IN):: T
    real(dp) PZ,b
    logical(lp) EXACT,CTIME


    IF(EXACT) THEN
       if(CTIME) then
          PZ=ROOT(1.0_dp+2.0_dp*X(5)/b+x(5)**2-X(2)**2-X(4)**2)
          X(1)=X(1)+L*X(2)/PZ
          X(3)=X(3)+L*X(4)/PZ
          X(6)=X(6)+L*(1.0_dp/b+X(5))/PZ-(1-T)*LD/b
       else
          PZ=ROOT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          X(1)=X(1)+L*X(2)/PZ
          X(3)=X(3)+L*X(4)/PZ
          X(6)=X(6)+L*(1.0_dp+X(5))/PZ-(1-T)*LD
       endif
    ELSE
       if(CTIME) then
          PZ=ROOT(1.0_dp+2.0_dp*X(5)/b+x(5)**2)
          X(1)=X(1)+L*X(2)/pz
          X(3)=X(3)+L*X(4)/pz
          ! bug found by Schmidt totalpath=false time=true
          !          X(6)=X(6)+((X(2)*X(2)+X(4)*X(4))/two/pz**2+T)*(one/b+x(5))*L/pz
          X(6)=X(6)+((X(2)*X(2)+X(4)*X(4))/2.0_dp/pz**2+1.0_dp)*(1.0_dp/b+x(5))*L/pz
          X(6)=X(6)-(1-T)*L/B
       else
          X(1)=X(1)+L*X(2)/(1.0_dp+X(5))
          X(3)=X(3)+L*X(4)/(1.0_dp+X(5))
          X(6)=X(6)+(L/(1.0_dp+X(5)))*(X(2)*X(2)+X(4)*X(4))/2.0_dp/(1.0_dp+X(5))+T*L
       endif
    ENDIF

  END SUBROUTINE DRIFTR

  SUBROUTINE DRIFTP(L,LD,b,T,EXACT,ctime,X)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN):: L
    real(dp), INTENT(IN):: LD
    INTEGER,INTENT(IN):: T
    TYPE(REAL_8) PZ
    logical(lp) EXACT,ctime
    real(dp) b

    IF(EXACT) THEN
       CALL ALLOC(PZ)
       if(ctime) then
          PZ=SQRT(1.0_dp+2.0_dp*X(5)/b+x(5)**2-X(2)**2-X(4)**2)
          X(1)=X(1)+L*X(2)/PZ
          X(3)=X(3)+L*X(4)/PZ
          X(6)=X(6)+L*(1.0_dp/b+X(5))/PZ-(1-T)*LD/b
       else
          PZ=SQRT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          X(1)=X(1)+L*X(2)/PZ
          X(3)=X(3)+L*X(4)/PZ
          X(6)=X(6)+L*(1.0_dp+X(5))/PZ-(1-T)*LD
       endif
       CALL KILL(PZ)
    ELSE
       if(ctime) then
          CALL ALLOC(PZ)
          PZ=SQRT(1.0_dp+2.0_dp*X(5)/b+x(5)**2)
          X(1)=X(1)+L*X(2)/pz
          X(3)=X(3)+L*X(4)/pz
          ! bug found by Schmidt totalpath=false time=true
          !          X(6)=X(6)+((X(2)*X(2)+X(4)*X(4))/two/pz**2+T)*(one/b+x(5))*L/pz
          X(6)=X(6)+((X(2)*X(2)+X(4)*X(4))/2.0_dp/pz**2+1.0_dp)*(1.0_dp/b+x(5))*L/pz
          X(6)=X(6)-(1-T)*L/B
          CALL KILL(PZ)
       else
          X(1)=X(1)+L*X(2)/(1.0_dp+X(5))
          X(3)=X(3)+L*X(4)/(1.0_dp+X(5))
          X(6)=X(6)+(L/(1.0_dp+X(5)))*(X(2)*X(2)+X(4)*X(4))/2.0_dp/(1.0_dp+X(5))+T*L
       endif
    ENDIF

  END SUBROUTINE DRIFTP

  SUBROUTINE KICKTR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(KICKT3),INTENT(IN):: EL
    real(dp) X1,X3,BBYTW,BBXTW,BBYTWT,pz,alfh
    INTEGER J,I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) myCOS,mySIN,ANG,XT(6)


    x(1)=x(1)-el%dx   ! sadistic stuff
    x(3)=x(3)-el%dy

    X1=X(1)
    X3=X(3)

    IF(EL%P%NMUL>=1) THEN
       BBYTW=EL%BN(EL%P%NMUL)
       BBXTW=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,1,-1
          BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
          BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
          BBYTW=BBYTWT
       ENDDO
    ELSE
       BBYTW=0.0_dp
       BBXTW=0.0_dp
    ENDIF
    if(el%patch) then
       alfh=-EL%thin_h_angle/2.0_dp
       call ROT_XZ(alfh,X,EL%P%BETA0,EL%P%exact.or.c_%ALWAYS_EXACT_PATCHING,k%TIME)
    endif
    IF(PRESENT(MID)) THEN
       CALL XMID(MID,X,0)

       CALL XMID(MID,X,1)

       CALL XMID(MID,X,1)
    ELSE
       if(k%TIME) then
          PZ=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%BETA0+x(5)**2)
          X(2)=X(2)+(-EL%thin_h_foc+EL%hf)*x1+EL%P%DIR*EL%P%CHARGE*EL%thin_h_angle*(PZ-1.0_dp)  ! highly illegal additions by frs
          X(4)=X(4)+(-EL%thin_v_foc+EL%vf)*x3+EL%P%DIR*EL%P%CHARGE*EL%thin_v_angle*(PZ-1.0_dp)  ! highly illegal additions by frs
          X(6)=X(6)+EL%P%DIR*EL%P%CHARGE*(EL%thin_h_angle*x1+EL%thin_v_angle*x3)*(1.0_dp/EL%P%BETA0+x(5))/pz
       else
          X(2)=X(2)+(-EL%thin_h_foc+EL%hf)*x1+EL%P%DIR*EL%P%CHARGE*EL%thin_h_angle*x(5)  ! highly illegal additions by frs
          X(4)=X(4)+(-EL%thin_v_foc+EL%vf)*x3+EL%P%DIR*EL%P%CHARGE*EL%thin_v_angle*x(5)  ! highly illegal additions by frs
          X(6)=X(6)+EL%P%DIR*EL%P%CHARGE*(EL%thin_h_angle*x1+EL%thin_v_angle*x3)
       endif

       X(2)=X(2)-EL%P%DIR*EL%P%CHARGE*BBYTW     ! BACKWARDS
       X(4)=X(4)+EL%P%DIR*EL%P%CHARGE*BBXTW     ! BACKWARDS
    ENDIF

!!!!!!!!!!!   solenoid

    if(k%TIME) then   ! bug 2006.1.8
       ANG=EL%B_SOL*EL%P%CHARGE/2.0_dp/root(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)*el%ls
       !       ANG=YL*EL%B_SOL*EL%P%dir*EL%P%CHARGE/two/root(one+two*X(5)/EL%P%beta0+x(5)**2) ! bug_intentional
    else
       ANG=EL%B_SOL*EL%P%CHARGE/2.0_dp/(1.0_dp+X(5))*el%ls
       !       ANG=YL*EL%B_SOL*EL%P%dir*EL%P%CHARGE/two/(one+X(5))   ! bug_intentional
    endif
    myCOS=COS(ANG)
    mySIN=SIN(ANG)
    ! NO EXACT EL%EXACT

    XT(1)=myCOS*X(1)+mySIN*X(3)
    XT(2)=myCOS*X(2)+mySIN*X(4)
    XT(3)=myCOS*X(3)-mySIN*X(1)
    XT(4)=myCOS*X(4)-mySIN*X(2)

    if(k%TIME) then
       X(6)=X(6)+ANG*(1.0_dp/EL%P%beta0+x(5))*(X(3)*X(2)-X(1)*X(4))/(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
    else
       X(6)=X(6)+ANG*(X(3)*X(2)-X(1)*X(4))/(1.0_dp+X(5))
    endif
    DO I=1,4
       X(I)=XT(I)
    ENDDO


    myCOS=(EL%B_SOL*EL%P%CHARGE)**2*el%ls

    if(k%TIME) then
       mySIN=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
       X(2)=X(2)-(myCOS)*X(1)/4.0_dp/mySIN
       X(4)=X(4)-(myCOS)*X(3)/4.0_dp/mySIN
       X(6)=X(6)+(1.0_dp/EL%P%beta0+x(5))*(myCOS)*(X(1)**2+X(3)**2)/8.0_dp/mySIN**3
    else
       X(2)=X(2)-(myCOS)*X(1)/4.0_dp/(1.0_dp+X(5))
       X(4)=X(4)-(myCOS)*X(3)/4.0_dp/(1.0_dp+X(5))
       X(6)=X(6)+(myCOS)*(X(1)**2+X(3)**2)/8.0_dp/(1.0_dp+X(5))**2
    endif


    !  end of solenoid





    if(el%patch) then
       alfh=-EL%thin_h_angle/2.0_dp
       call ROT_XZ(alfh,X,EL%P%BETA0,EL%P%exact.or.c_%ALWAYS_EXACT_PATCHING,k%TIME)
    endif


    x(1)=x(1)+el%dx
    x(3)=x(3)+el%dy


  END SUBROUTINE KICKTR


  SUBROUTINE KICKTP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    ! TYPE(WORM_8),OPTIONAL,INTENT(INOUT):: MID
    TYPE(KICKT3P),INTENT(IN):: EL
    TYPE(REAL_8) X1,X3,BBYTW,BBXTW,BBYTWT
    TYPE(REAL_8) pz
    INTEGER J,i
    real(dp) alfh
    TYPE(REAL_8) myCOS,mySIN,ANG,XT(6)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ALLOC(X1)
    CALL ALLOC(X3)
    CALL ALLOC(BBYTW)
    CALL ALLOC(BBXTW)
    CALL ALLOC(BBYTWT)
    CALL ALLOC(myCOS,mySIN,ANG)
    CALL ALLOC(XT)



    x(1)=x(1)-el%dx
    x(3)=x(3)-el%dy

    X1=X(1)
    X3=X(3)


    IF(EL%P%NMUL>=1) THEN
       BBYTW=EL%BN(EL%P%NMUL)
       BBXTW=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,1,-1
          BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
          BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
          BBYTW=BBYTWT
       ENDDO
    ELSE
       BBYTW=0.0_dp
       BBXTW=0.0_dp
    ENDIF


    if(el%patch) then
       alfh=-EL%thin_h_angle/2.0_dp
       call ROT_XZ(alfh,X,EL%P%BETA0,EL%P%exact.or.c_%ALWAYS_EXACT_PATCHING,k%TIME)
    endif

    if(k%TIME) then
       call alloc(pz)
       PZ=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%BETA0+x(5)**2)
       X(2)=X(2)+(-EL%thin_h_foc+EL%hf)*x1+EL%P%DIR*EL%P%CHARGE*EL%thin_h_angle*(PZ-1.0_dp)  ! highly illegal additions by frs
       X(4)=X(4)+(-EL%thin_v_foc+EL%vf)*x3+EL%P%DIR*EL%P%CHARGE*EL%thin_v_angle*(PZ-1.0_dp)  ! highly illegal additions by frs
       X(6)=X(6)+EL%P%DIR*EL%P%CHARGE*(EL%thin_h_angle*x1+EL%thin_v_angle*x3)*(1.0_dp/EL%P%BETA0+x(5))/pz
       call kill(pz)
    else
       X(2)=X(2)+(-EL%thin_h_foc+EL%hf)*x1+EL%P%DIR*EL%P%CHARGE*EL%thin_h_angle*x(5)  ! highly illegal additions by frs
       X(4)=X(4)+(-EL%thin_v_foc+EL%vf)*x3+EL%P%DIR*EL%P%CHARGE*EL%thin_v_angle*x(5)  ! highly illegal additions by frs
       X(6)=X(6)+EL%P%DIR*EL%P%CHARGE*(EL%thin_h_angle*x1+EL%thin_v_angle*x3)
    endif

    X(2)=X(2)-EL%P%DIR*EL%P%CHARGE*BBYTW     ! BACKWARDS
    X(4)=X(4)+EL%P%DIR*EL%P%CHARGE*BBXTW     ! BACKWARDS
    !    ENDIF

!!!!!!!!!!!   solenoid

    if(k%TIME) then   ! bug 2006.1.8
       ANG=EL%B_SOL*EL%P%CHARGE/2.0_dp/sqrt(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)*el%ls
       !       ANG=YL*EL%B_SOL*EL%P%dir*EL%P%CHARGE/two/root(one+two*X(5)/EL%P%beta0+x(5)**2) ! bug_intentional
    else
       ANG=EL%B_SOL*EL%P%CHARGE/2.0_dp/(1.0_dp+X(5))*el%ls
       !       ANG=YL*EL%B_SOL*EL%P%dir*EL%P%CHARGE/two/(one+X(5))   ! bug_intentional
    endif
    myCOS=COS(ANG)
    mySIN=SIN(ANG)
    ! NO EXACT EL%EXACT

    XT(1)=myCOS*X(1)+mySIN*X(3)
    XT(2)=myCOS*X(2)+mySIN*X(4)
    XT(3)=myCOS*X(3)-mySIN*X(1)
    XT(4)=myCOS*X(4)-mySIN*X(2)

    if(k%TIME) then
       X(6)=X(6)+ANG*(1.0_dp/EL%P%beta0+x(5))*(X(3)*X(2)-X(1)*X(4))/(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
    else
       X(6)=X(6)+ANG*(X(3)*X(2)-X(1)*X(4))/(1.0_dp+X(5))
    endif
    DO I=1,4
       X(I)=XT(I)
    ENDDO


    !  end of solenoid


    myCOS=(EL%B_SOL*EL%P%CHARGE)**2*el%ls

    if(k%TIME) then
       mySIN=sqrt(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
       X(2)=X(2)-(myCOS)*X(1)/4.0_dp/mySIN
       X(4)=X(4)-(myCOS)*X(3)/4.0_dp/mySIN
       X(6)=X(6)+(1.0_dp/EL%P%beta0+x(5))*(myCOS)*(X(1)**2+X(3)**2)/8.0_dp/mySIN**3
    else
       X(2)=X(2)-(myCOS)*X(1)/4.0_dp/(1.0_dp+X(5))
       X(4)=X(4)-(myCOS)*X(3)/4.0_dp/(1.0_dp+X(5))
       X(6)=X(6)+(myCOS)*(X(1)**2+X(3)**2)/8.0_dp/(1.0_dp+X(5))**2
    endif




    if(el%patch) then
       alfh=-EL%thin_h_angle/2.0_dp
       call ROT_XZ(alfh,X,EL%P%BETA0,EL%P%exact.or.c_%ALWAYS_EXACT_PATCHING,k%TIME)
    endif


    x(1)=x(1)+el%dx
    x(3)=x(3)+el%dy


    CALL KILL(myCOS,mySIN,ANG)
    CALL KILL(XT)
    CALL KILL(X1)
    CALL KILL(X3)
    CALL KILL(BBYTW)
    CALL KILL(BBXTW)
    CALL KILL(BBYTWT)

  END SUBROUTINE KICKTP

  SUBROUTINE MULTIPOLE_FRINGER(EL,AN,BN,K1,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN),dimension(:)::AN,BN
    TYPE(MAGNET_CHART),INTENT(IN):: EL
    INTEGER, INTENT(IN) :: K1
    real(dp) A,B,C,D,DEL,X2
    INTEGER J
    real(dp) RX,IX,DRX,DIX,U,V,DU,DV,NF
    real(dp) DUX,DUY,DVX,DVY,FX_X,FX_Y,FY_X,FY_Y,FX,FY
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) i

    IF(EL%NMUL<=1) RETURN

    IF(K1==1.AND.EL%KILL_ENT_FRINGE) RETURN
    IF(K1==2.AND.EL%KILL_EXI_FRINGE) RETURN


    IF(K1==1) THEN
       I= EL%CHARGE
    ELSE
       I=-EL%CHARGE
    ENDIF

    FX=0.0_dp
    FY=0.0_dp
    FX_X=0.0_dp
    FX_Y=0.0_dp
    FY_X=0.0_dp
    FY_Y=0.0_dp

    RX=1.0_dp
    IX=0.0_dp

    !   RX=X(1)
    !   IX=X(3)

    DO J=1,MIN(EL%NMUL,el%HIGHEST_FRINGE)
       DRX=  RX
       DIX=  IX
       RX =  DRX*X(1)-DIX*X(3)
       IX =  DRX*X(3)+DIX*X(1)    ! COMPUTING (X+IY)**J

       IF(J==1.AND.EL%BEND_FRINGE) THEN
          U =     -  AN(J)*IX
          V =     +  AN(J)*RX
          DU =    -  AN(J)*DIX
          DV =    +  AN(J)*DRX
       ELSE
          U =   BN(J)*RX   -  AN(J)*IX
          V =   BN(J)*IX   +  AN(J)*RX
          DU =  BN(J)*DRX  -  AN(J)*DIX
          DV =  BN(J)*DIX  +  AN(J)*DRX
       ENDIF

       U  = (-I/4.0_dp/(J+1))*U
       V  = (-I/4.0_dp/(J+1))*V
       DU = (-I/4.0_dp/(J+1))*DU
       DV = (-I/4.0_dp/(J+1))*DV

       DUX = J*DU
       DVX = J*DV
       DUY =-J*DV
       DVY = J*DU

       NF= REAL(J+2,kind=DP)/ REAL(J,kind=DP)

       FX=FX+( U*X(1) + NF*V*X(3))
       FY=FY+( U*X(3) - NF*V*X(1))

       FX_X=FX_X+ (DUX*X(1)+U+NF*X(3)*DVX)
       FX_Y=FX_Y+ (DUY*X(1)+NF*V+NF*X(3)*DVY)

       FY_X=FY_X+ (DUX*X(3)-NF*V-NF*X(1)*DVX)
       FY_Y=FY_Y+ (DUY*X(3)+U-NF*X(1)*DVY)

    ENDDO

    if(k%TIME) then
       del=1.0_dp/ROOT(1.0_dp+2.0_dp*X(5)/el%beta0+x(5)**2)
    else
       DEL=1.0_dp/(1.0_dp+X(5))
    endif




    A=1.0_dp-FX_X*DEL
    B=-FY_X*DEL
    D=1.0_dp-FY_Y*DEL
    C=-FX_Y*DEL

    X(1)=X(1)-FX*DEL
    X2=(D*X(2)-B*X(4))/(A*D-B*C)
    X(4)=(A*X(4)-C*X(2))/(A*D-B*C)
    X(2)=X2
    X(3)=X(3)-FY*DEL
    if(k%TIME) then
       X(6)=X(6)-(1.0_dp/el%beta0+x(5))*(X(2)*FX+X(4)*FY)*DEL**3
    else
       X(6)=X(6)-(X(2)*FX+X(4)*FY)*DEL**2
    endif
    !    CALL CHECK_STABILITY(X)
    call check_root_drift(el,X,k)
  END SUBROUTINE MULTIPOLE_FRINGER

  SUBROUTINE MULTIPOLE_FRINGEP(EL,AN,BN,K1,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN),dimension(:)::AN,BN
    TYPE(MAGNET_CHART),INTENT(IN):: EL
    INTEGER, INTENT(IN) :: K1
    INTEGER J
    TYPE(REAL_8) A,B,C,D,DEL,X2
    TYPE(REAL_8) RX,IX,DRX,DIX,U,V,DU,DV
    TYPE(REAL_8) DUX,DUY,DVX,DVY,FX_X,FX_Y,FY_X,FY_Y,FX,FY
    REAL(DP) NF
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) i



    IF(EL%NMUL<=1) RETURN

    IF(K1==1.AND.EL%KILL_ENT_FRINGE) RETURN
    IF(K1==2.AND.EL%KILL_EXI_FRINGE) RETURN

    CALL ALLOC(DUX,DUY,DVX,DVY,FX_X,FX_Y,FY_X,FY_Y,FX,FY)
    CALL ALLOC(RX,IX,DRX,DIX,U,V,DU,DV)
    CALL ALLOC(A,B,C,D,DEL,X2)

    IF(K1==1) THEN
       I= EL%CHARGE
    ELSE
       I=-EL%CHARGE
    ENDIF

    FX=0.0_dp
    FY=0.0_dp
    FX_X=0.0_dp
    FX_Y=0.0_dp
    FY_X=0.0_dp
    FY_Y=0.0_dp
    RX=1.0_dp
    IX=0.0_dp

    !   RX=X(1)
    !   IX=X(3)

    DO J=1,MIN(EL%NMUL,el%HIGHEST_FRINGE)
       DRX=  RX
       DIX=  IX
       RX =  DRX*X(1)-DIX*X(3)
       IX =  DRX*X(3)+DIX*X(1)    ! COMPUTING (X+IY)**J

       IF(J==1.AND.EL%BEND_FRINGE) THEN
          U =     -  AN(J)*IX
          V =     +  AN(J)*RX
          DU =    -  AN(J)*DIX
          DV =    +  AN(J)*DRX
       ELSE
          U =   BN(J)*RX   -  AN(J)*IX
          V =   BN(J)*IX   +  AN(J)*RX
          DU =  BN(J)*DRX  -  AN(J)*DIX
          DV =  BN(J)*DIX  +  AN(J)*DRX
       ENDIF

       U  = (-I/4.0_dp/(J+1))*U
       V  = (-I/4.0_dp/(J+1))*V
       DU = (-I/4.0_dp/(J+1))*DU
       DV = (-I/4.0_dp/(J+1))*DV

       DUX = J*DU
       DVX = J*DV
       DUY =-J*DV
       DVY = J*DU

       NF= REAL(J+2,kind=DP)/ REAL(J,kind=DP)

       FX=FX+( U*X(1) + NF*V*X(3))
       FY=FY+( U*X(3) - NF*V*X(1))

       FX_X=FX_X+ (DUX*X(1)+U+NF*X(3)*DVX)
       FX_Y=FX_Y+ (DUY*X(1)+NF*V+NF*X(3)*DVY)

       FY_X=FY_X+ (DUX*X(3)-NF*V-NF*X(1)*DVX)
       FY_Y=FY_Y+ (DUY*X(3)+U-NF*X(1)*DVY)

    ENDDO

    if(k%TIME) then
       del=1.0_dp/SQRT(1.0_dp+2.0_dp*X(5)/el%beta0+x(5)**2)
    else
       DEL=1.0_dp/(1.0_dp+X(5))
    endif




    A=1.0_dp-FX_X*DEL
    B=-FY_X*DEL
    D=1.0_dp-FY_Y*DEL
    C=-FX_Y*DEL

    X(1)=X(1)-FX*DEL
    X2=(D*X(2)-B*X(4))/(A*D-B*C)
    X(4)=(A*X(4)-C*X(2))/(A*D-B*C)
    X(2)=X2
    X(3)=X(3)-FY*DEL
    if(k%TIME) then
       X(6)=X(6)-(1.0_dp/el%beta0+x(5))*(X(2)*FX+X(4)*FY)*DEL**3
    else
       X(6)=X(6)-(X(2)*FX+X(4)*FY)*DEL**2
    endif

    CALL KILL(DUX,DUY,DVX,DVY,FX_X,FX_Y,FY_X,FY_Y,FX,FY)
    CALL KILL(RX,IX,DRX,DIX,U,V,DU,DV)
    CALL KILL(A,B,C,D,DEL,X2)


  END SUBROUTINE MULTIPOLE_FRINGEP

  SUBROUTINE NEWFACER(EL,BN,H,X,k)
    IMPLICIT NONE
    TYPE(MAGNET_CHART),INTENT(IN):: EL
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN)::H
    real(dp),INTENT(IN),dimension(:)::BN
    real(dp) XI,PM,DXI_PX,DXI_DDEL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    IF(EL%DIR==1) THEN   ! NOT IMPORTANT; JUST TO INSURE REVERSAL SYMMETRY
       ! HORIZONTAL WEDGE
       X(2)=X(2)+(EL%DIR*EL%CHARGE*BN(1)*H/2.0_dp)*X(1)**2
    ENDIF

    IF(k%TIME) THEN
       PM=ROOT(1.0_dp+2.0_dp*X(5)/el%beta0+x(5)**2-X(2)**2)
       XI=EL%DIR*EL%CHARGE*ROOT(1.0_dp+2.0_dp*X(5)/el%beta0+x(5)**2)*BN(1)*H/PM**2
       DXI_PX=2.0_dp*X(2)/PM**2 * XI
       DXI_DDEL=-2.0_dp*(1.0_dp+X(5))/PM**2 * XI
    ELSE
       PM=ROOT((1.0_dp+X(5))**2-X(2)**2)
       XI=EL%DIR*EL%CHARGE*(1.0_dp+X(5))*BN(1)*H/PM**2
       DXI_PX=2.0_dp*X(2)/PM**2 * XI
       DXI_DDEL=-2.0_dp*(1.0_dp/EL%BETA0+X(5))/PM**2 * XI
    ENDIF

    X(1)=X(1)/(1.0_dp-DXI_PX*X(3)**2)
    X(2)=X(2)-XI*X(3)**2
    X(4)=X(4)-2.0_dp*XI*X(1)*X(3)
    X(6)=X(6)-DXI_DDEL*X(1)*X(3)**2

    IF(EL%DIR==-1) THEN   ! NOT IMPORTANT; JUST TO INSURE REVERSAL SYMMETRY
       ! HORIZONTAL WEDGE
       X(2)=X(2)+(EL%DIR*EL%CHARGE*BN(1)*H/2.0_dp)*X(1)**2
    ENDIF
    !    CALL check_stability(X)
    call check_root_drift(el,X,k)
  END SUBROUTINE NEWFACER

  SUBROUTINE NEWFACEP(EL,BN,H,X,k)
    IMPLICIT NONE
    TYPE(MAGNET_CHART),INTENT(IN):: EL
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN)::H
    TYPE(REAL_8),INTENT(IN),dimension(:)::BN
    TYPE(REAL_8) XI,PM,DXI_PX,DXI_DDEL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    CALL ALLOC(XI,PM,DXI_PX,DXI_DDEL)

    IF(EL%DIR==1) THEN   ! NOT IMPORTANT; JUST TO INSURE REVERSAL SYMMETRY
       ! HORIZONTAL WEDGE
       X(2)=X(2)+(EL%DIR*EL%CHARGE*BN(1)*H/2.0_dp)*X(1)**2
    ENDIF

    IF(k%TIME) THEN
       PM=SQRT(1.0_dp+2.0_dp*X(5)/el%beta0+x(5)**2-X(2)**2)
       XI=EL%DIR*EL%CHARGE* SQRT(1.0_dp+2.0_dp*X(5)/el%beta0+x(5)**2)*BN(1)*H/PM**2
       DXI_PX=2.0_dp*X(2)/PM**2 * XI
       DXI_DDEL=-2.0_dp*(1.0_dp+X(5))/PM**2 * XI
    ELSE
       PM=SQRT((1.0_dp+X(5))**2-X(2)**2)
       XI=EL%DIR*EL%CHARGE*(1.0_dp+X(5))*BN(1)*H/PM**2
       DXI_PX=2.0_dp*X(2)/PM**2 * XI
       DXI_DDEL=-2.0_dp*(1.0_dp/EL%BETA0+X(5))/PM**2 * XI
    ENDIF

    X(1)=X(1)/(1.0_dp-DXI_PX*X(3)**2)
    X(2)=X(2)-XI*X(3)**2
    X(4)=X(4)-2.0_dp*XI*X(1)*X(3)
    X(6)=X(6)-DXI_DDEL*X(1)*X(3)**2

    IF(EL%DIR==-1) THEN   ! NOT IMPORTANT; JUST TO INSURE REVERSAL SYMMETRY
       ! HORIZONTAL WEDGE
       X(2)=X(2)+(EL%DIR*EL%CHARGE*BN(1)*H/2.0_dp)*X(1)**2
    ENDIF

    CALL KILL(XI,PM,DXI_PX,DXI_DDEL)


  END SUBROUTINE NEWFACEP

  SUBROUTINE FACER(DIR,BN,H,E,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN)::H,E
    real(dp),INTENT(IN),dimension(:)::BN
    real(dp),INTENT(IN):: DIR
    real(dp) C
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    C=1.0_dp/COS(E)**3

    X(2)=X(2)+(DIR*BN(1)*H/2.0_dp)*X(1)**2
    X(2)=X(2)-(DIR*BN(1)*H*C/2.0_dp)*X(3)**2
    X(4)=X(4)-(DIR*BN(1)*H*C)*X(1)*X(3)

  END SUBROUTINE FACER

  SUBROUTINE FACEP(DIR,BN,H,E,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN)::H
    TYPE(REAL_8),INTENT(IN),dimension(:)::BN
    real(dp),INTENT(IN):: E
    real(dp),INTENT(IN):: DIR
    real(dp) C
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    C=1.0_dp/COS(E)**3

    X(2)=X(2)+(DIR*BN(1)*H/2.0_dp)*X(1)**2
    X(2)=X(2)-(DIR*BN(1)*H*C/2.0_dp)*X(3)**2
    X(4)=X(4)-(DIR*BN(1)*H*C)*X(1)*X(3)

  END SUBROUTINE FACEP

  SUBROUTINE FRINGE_dipoleR(EL,BN,FINT,HGAP,K1,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN)::FINT,HGAP
    real(dp),INTENT(IN),dimension(:)::BN
    TYPE(MAGNET_CHART),INTENT(IN):: EL
    INTEGER, INTENT(IN) :: K1
    real(dp) PZ,XP,YP,TIME_FAC
    real(dp) D(3,3),FI(3),FI0,B,co1,co2
    real(dp) fsad,c3,rel_p
    integer i
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    !    if((.not.el%exact)) then
    !     write(6,*) " Fringer should be called in exact magnets only "
    !     stop 101
    !    endif
    IF(.not.EL%exact) RETURN
    IF(.not.EL%BEND_FRINGE) RETURN
    IF(K1==1.AND.EL%KILL_ENT_FRINGE) RETURN
    IF(K1==2.AND.EL%KILL_EXI_FRINGE) RETURN

    fsad=0.0_dp
    if(fint*hgap/=0.0_dp) then
      fsad=1.d0/(fint*hgap*2)/36.0_dp
    endif

    IF(K1==1) THEN
       B=EL%CHARGE*BN(1)
    ELSE
       B=-EL%CHARGE*BN(1)
    ENDIF


    if(k%TIME) then
       PZ=ROOT(1.0_dp+2.0_dp*X(5)/el%beta0+x(5)**2-X(2)**2-X(4)**2)
       TIME_FAC=1.0_dp/el%beta0+X(5)
       rel_p=root(1.0_dp+2.0_dp*X(5)/el%beta0+x(5)**2)
    else
       PZ=ROOT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
       TIME_FAC=1.0_dp+X(5)
       rel_p=time_fac
    endif

    c3=b**2*fsad/rel_p

    XP=X(2)/PZ ; YP=X(4)/PZ;

    D(1,1)=(1.0_dp+XP**2)/PZ
    D(2,1)=XP*YP/PZ
    D(3,1)=-XP
    D(1,2)=XP*YP/PZ
    D(2,2)=(1.0_dp+YP**2)/PZ
    D(3,2)=-YP
    D(1,3)=-TIME_FAC*XP/PZ**2
    D(2,3)=-TIME_FAC*YP/PZ**2
    D(3,3)= TIME_FAC/PZ

    !    FI0=(B*XP/(one+yp**2)-B2* ( ONE + XP**2*(TWO+YP**2) )/PZ)
    !    FI0= arctan((XP/(one+yp**2)))    !-B*FINT*HGAP*two*( ONE + XP**2*(TWO+YP**2) )   *PZ
    FI0= ATAN((XP/(1.0_dp+yp**2)))-B*FINT*HGAP*2.0_dp*( 1.0_dp + XP**2*(2.0_dp+YP**2) )*PZ
    CO2=B/COS(FI0)**2
    CO1=CO2/(1.0_dp+(XP/(1.0_dp+yp**2))**2 )

    FI(1)=CO1/(1.0_dp+yp**2)-CO2*B*FINT*HGAP*2.0_dp*( 2.0_dp*XP*(2.0_dp+YP**2)*PZ )
    FI(2)=-CO1*2.0_dp*XP*YP/(1.0_dp+yp**2)**2-CO2*B*FINT*HGAP*2.0_dp*( 2.0_dp*XP**2*YP)*PZ
    FI(3)=-CO2*B*FINT*HGAP*2.0_dp*( 1.0_dp + XP**2*(2.0_dp+YP**2) )

    FI0=B*TAN(FI0)


    !       X(4)=X(4)-TAN(EL%EDGE(I)-EL%DIR*EL%CHARGE*two*FINT*HGAP*(ONE+SIN(EL%EDGE(I))**2)*BN(1)/COS(EL%EDGE(I))) &
    !       & *EL%DIR*EL%CHARGE*BN(1)*X(3)   ! SECTOR WEDGE (PROT) + FRINGE

    B=0.0_dp
    DO i=1,3
       B=FI(I)*D(I,2)+B
    ENDDO
    X(3)=2.0_dp*X(3)/(1.0_dp+ sqrt(1.0_dp-2.0_dp*B*X(3)) )
    X(4)=X(4)-FI0*X(3)

    B=0.0_dp
    DO i=1,3
       B=FI(I)*D(I,1)+B
    ENDDO
    X(1)=X(1)+0.5_dp*B*X(3)**2

    B=0.0_dp
    DO i=1,3
       B=FI(I)*D(I,3)+B
    ENDDO
    X(6)=X(6)-0.5_dp*B*X(3)**2

!!! coming to you with sadistic delight

     x(4)=x(4)-4*c3*x(3)**3
     x(6)=x(6)+c3*x(3)**4/rel_p**2*time_fac
!!! 

    !    CALL check_stability(X)
    call check_root_drift(el,X,k)
  END SUBROUTINE FRINGE_dipoleR


  SUBROUTINE FRINGE_dipoleP(EL,BN,FINT,HGAP,K1,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN)::FINT,HGAP
    TYPE(REAL_8),INTENT(IN),dimension(:)::BN
    TYPE(MAGNET_CHART),INTENT(IN):: EL
    INTEGER, INTENT(IN) :: K1
    TYPE(REAL_8) PZ,XP,YP,TIME_FAC,FI0,B
    TYPE(REAL_8) D(3,3),FI(3),CO1,CO2
    TYPE(REAL_8) fsad,c3,rel_p
    integer i,J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    ! etienne

    !    if((.not.el%exact)) then
    !     write(6,*) " Fringep should be called in exact magnets only "
    !     stop 102
    !    endif

    IF(.not.EL%exact) RETURN
    IF(.not.EL%BEND_FRINGE) RETURN
    IF(K1==1.AND.EL%KILL_ENT_FRINGE) RETURN
    IF(K1==2.AND.EL%KILL_EXI_FRINGE) RETURN

    CALL ALLOC(PZ,XP,YP,TIME_FAC,FI0,B,CO1,CO2)
    call alloc(fsad,c3,rel_p)

    DO I=1,3
       CALL ALLOC(FI(I))
       DO J=1,3
          CALL ALLOC(D(I,J))
       ENDDO
    ENDDO

    IF(K1==1) THEN
       B=EL%CHARGE*BN(1)
    ELSE
       B=-EL%CHARGE*BN(1)
    ENDIF

    fsad=0.0_dp
    if(fint*hgap/=0.0_dp) then
      fsad=1.d0/(fint*hgap*2)/36.0_dp
    endif


    if(k%TIME) then
       PZ=sqrt(1.0_dp+2.0_dp*X(5)/el%beta0+x(5)**2-X(2)**2-X(4)**2)
       TIME_FAC=1.0_dp/el%beta0+X(5)
       rel_p=sqrt(1.0_dp+2.0_dp*X(5)/el%beta0+x(5)**2)
    else
       PZ=sqrt((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
       TIME_FAC=1.0_dp+X(5)
       rel_p=time_fac
    endif

    c3=b**2*fsad/rel_p

    XP=X(2)/PZ ; YP=X(4)/PZ;

    D(1,1)=(1.0_dp+XP**2)/PZ
    D(2,1)=XP*YP/PZ
    D(3,1)=-XP
    D(1,2)=XP*YP/PZ
    D(2,2)=(1.0_dp+YP**2)/PZ
    D(3,2)=-YP
    D(1,3)=-TIME_FAC*XP/PZ**2
    D(2,3)=-TIME_FAC*YP/PZ**2
    D(3,3)= TIME_FAC/PZ

    !    FI0=(B*XP/(one+yp**2)-B2* ( ONE + XP**2*(TWO+YP**2) )/PZ)
    !    FI0=(XP/(one+yp**2))
    !    FI0= ATAN(FI0)-B*FINT*HGAP*two*( ONE + XP**2*(TWO+YP**2) )*PZ
    FI0= ATAN((XP/(1.0_dp+yp**2)))-B*FINT*HGAP*2.0_dp*( 1.0_dp + XP**2*(2.0_dp+YP**2) )*PZ
    CO2=B/COS(FI0)**2
    CO1=CO2/(1.0_dp+(XP/(1.0_dp+yp**2))**2 )

    FI(1)=CO1/(1.0_dp+yp**2)-CO2*B*FINT*HGAP*2.0_dp*( 2.0_dp*XP*(2.0_dp+YP**2)*PZ )
    FI(2)=-CO1*2.0_dp*XP*YP/(1.0_dp+yp**2)**2-CO2*B*FINT*HGAP*2.0_dp*( 2.0_dp*XP**2*YP)*PZ
    FI(3)=-CO2*B*FINT*HGAP*2.0_dp*( 1.0_dp + XP**2*(2.0_dp+YP**2) )

    FI0=B*TAN(FI0)


    !       X(4)=X(4)-TAN(EL%EDGE(I)-EL%DIR*EL%CHARGE*two*FINT*HGAP*(ONE+SIN(EL%EDGE(I))**2)*BN(1)/COS(EL%EDGE(I))) &
    !       & *EL%DIR*EL%CHARGE*BN(1)*X(3)   ! SECTOR WEDGE (PROT) + FRINGE

    B=0.0_dp
    DO i=1,3
       B=FI(I)*D(I,2)+B
    ENDDO
    X(3)=2.0_dp*X(3)/(1.0_dp+ sqrt(1.0_dp-2.0_dp*B*X(3)) )
    X(4)=X(4)-FI0*X(3)

    B=0.0_dp
    DO i=1,3
       B=FI(I)*D(I,1)+B
    ENDDO
    X(1)=X(1)+0.5_dp*B*X(3)**2

    B=0.0_dp
    DO i=1,3
       B=FI(I)*D(I,3)+B
    ENDDO
    X(6)=X(6)-0.5_dp*B*X(3)**2

!!! coming to you with sadistic delight

     x(4)=x(4)-4*c3*x(3)**3
     x(6)=x(6)+c3*x(3)**4/rel_p**2*time_fac
!!! 

    call KILL(fsad,c3,rel_p)
    CALL KILL(PZ,XP,YP,TIME_FAC,FI0,B,CO1,CO2)
    DO I=1,3
       CALL KILL(FI(I))
       DO J=1,3
          CALL KILL(D(I,J))
       ENDDO
    ENDDO

  END SUBROUTINE FRINGE_dipoleP

  SUBROUTINE FRINGE2QUADR(EL,b2,a2,FINT,HGAP,K1,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN)::FINT,HGAP
    INTEGER, INTENT(IN) :: K1
    real(dp),INTENT(IN) :: b2,a2
    TYPE(MAGNET_CHART),INTENT(IN):: EL
    real(dp) PZ,TIME_FAC
    real(dp) f1,f2,b,ang
    integer i

    TYPE(INTERNAL_STATE) k

    IF(K1==1.AND.EL%KILL_ENT_FRINGE) RETURN
    IF(K1==2.AND.EL%KILL_EXI_FRINGE) RETURN

    if(k%TIME) then
       PZ=ROOT(1.0_dp+2.0_dp*X(5)/el%beta0+x(5)**2)
       TIME_FAC=(1.0_dp/el%beta0+X(5))/PZ
    else
       PZ=1.0_dp+X(5)
       TIME_FAC=1.0_dp
    endif


    IF(K1==1) THEN
       I= EL%CHARGE
    ELSE
       I=-EL%CHARGE
    ENDIF

    
    b=sqrt(b2**2+a2**2)
    f1=-i*fint*abs(fint)*b/pz/24.0_dp
    f2=hgap*b/pz

    ang=-atan2(a2,b2)/2.0_dp

    call ROT_XY(Ang,X)

    x(6)=x(6)+time_fac*(f1*x(1)+f2*(1+f1/2)*x(2)/pz*exp(-f1))*x(2)/pz  &
             -time_fac*(f1*x(3)+f2*(1-f1/2)*x(4)/pz*exp( f1))*x(4)/pz            

    x(1)=x(1)*exp(f1)+x(2)*f2/pz
    x(3)=x(3)*exp(-f1)-x(4)*f2/pz

    x(2)=x(2)*exp(-f1)
    x(4)=x(4)*exp(f1)

    call ROT_XY(-Ang,X)

  END SUBROUTINE FRINGE2QUADR



  SUBROUTINE FRINGE2QUADp(EL,b2,a2,FINT,HGAP,K1,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN)::FINT,HGAP,b2,a2
    INTEGER, INTENT(IN) :: K1
    TYPE(MAGNET_CHART),INTENT(IN):: EL
    TYPE(REAL_8) PZ,TIME_FAC,f1,f2
    real(dp) b,ang
    integer i

    TYPE(INTERNAL_STATE) k

    IF(K1==1.AND.EL%KILL_ENT_FRINGE) RETURN
    IF(K1==2.AND.EL%KILL_EXI_FRINGE) RETURN
    if(.not. tpsa_quad_sad) then
    if(a2%kind/=1.or.b2%kind/=1) then
     write(6,*) " quadrupole strengths cannot be Taylors in FRINGE2QUADP "
     stop
    endif 
    endif

    call alloc(PZ,TIME_FAC,f1,f2)

    if(k%TIME) then
       PZ=sqrt(1.0_dp+2.0_dp*X(5)/el%beta0+x(5)**2)
       TIME_FAC=(1.0_dp/el%beta0+X(5))/PZ
    else
       PZ=1.0_dp+X(5)
       TIME_FAC=1.0_dp
    endif


    IF(K1==1) THEN
       I= EL%CHARGE
    ELSE
       I=-EL%CHARGE
    ENDIF

    if(tpsa_quad_sad) then
     b=sqrt(b2**2+a2**2)
    else
     b=sqrt(b2%r**2+a2%r**2)
    endif

    f1=-i*fint*abs(fint)*b/pz/24.0_dp
    f2=hgap*b/pz

    ang=-atan2(a2%r,b2%r)/2.0_dp

    call ROT_XY(Ang,X)

    x(6)=x(6)+time_fac*(f1*x(1)+f2*(1+f1/2)*x(2)/pz*exp(-f1))*x(2)/pz  &
             -time_fac*(f1*x(3)+f2*(1-f1/2)*x(4)/pz*exp( f1))*x(4)/pz    

    x(1)=x(1)*exp(f1)+x(2)*f2/pz
    x(3)=x(3)*exp(-f1)-x(4)*f2/pz

    x(2)=x(2)*exp(-f1)
    x(4)=x(4)*exp(f1)

    call ROT_XY(-Ang,X)
    
    call KILL(PZ,TIME_FAC,f1,f2)

  END SUBROUTINE FRINGE2QUADP


  SUBROUTINE EDGE_TRUE_PARALLELR(EL,BN,H1,H2,FINT,HGAP,I,X,k)
    IMPLICIT NONE
    logical(lp) :: doneitt=.true.
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN)::FINT,HGAP,H1,H2
    real(dp),INTENT(IN),dimension(:)::BN
    TYPE(MAGNET_CHART),INTENT(IN):: EL
    INTEGER, INTENT(IN) :: I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(EL%EXACT) THEN
       IF(EL%DIR==1) THEN
          IF(I==1) then                !doubling entrance angle if first half  (1/2 magnet for designer)
             call ROT_XZ(EL%EDGE(1),X,EL%BETA0,DONEITT,k%TIME)
             CALL FACE(EL,BN,H1,X,k)
          endif
          CALL FRINGE_dipole(EL,BN,FINT,HGAP,I,X,k)
          IF(I==2) then                !doubling exit angle if second half
             CALL FACE(EL,BN,H2,X,k)
             x(1)=x(1)+EL%LC*SIN((EL%EDGE(2)-EL%EDGE(1))*0.5_dp)
             call ROT_XZ(EL%EDGE(2),X,EL%BETA0,DONEITT,k%TIME)
          endif
       ELSE
          IF(I==2) then                !doubling exit angle if second half
             call ROT_XZ(EL%EDGE(2),X,EL%BETA0,DONEITT,k%TIME)
             x(1)=x(1)+EL%DIR*EL%LC*SIN((EL%EDGE(2)-EL%EDGE(1))*0.5_dp)
             CALL FACE(EL,BN,H2,X,k)
          endif
          CALL FRINGE_dipole(EL,BN,FINT,HGAP,I,X,k)
          IF(I==1) then                !doubling entrance angle if first half  (1/2 magnet for designer)
             CALL FACE(EL,BN,H1,X,k)
             call ROT_XZ(EL%EDGE(1),X,EL%BETA0,DONEITT,k%TIME)
          endif
       ENDIF

    ELSE
       WRITE(6,*) "ERROR 777"
       STOP 777
    ENDIF

  END SUBROUTINE EDGE_TRUE_PARALLELR

  SUBROUTINE EDGE_TRUE_PARALLELP(EL,BN,H1,H2,FINT,HGAP,I,X,k)
    IMPLICIT NONE
    logical(lp) :: doneitt=.true.
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN)::FINT,HGAP,H1,H2
    TYPE(REAL_8),INTENT(IN),dimension(:)::BN
    TYPE(MAGNET_CHART),INTENT(IN):: EL
    INTEGER, INTENT(IN) :: I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(EL%EXACT) THEN
       IF(EL%DIR==1) THEN
          IF(I==1) then                !doubling entrance angle if first half  (1/2 magnet for designer)
             call ROT_XZ(EL%EDGE(1),X,EL%BETA0,DONEITT,k%TIME)
             CALL FACE(EL,BN,H1,X,k)
          endif
          CALL FRINGE_dipole(EL,BN,FINT,HGAP,I,X,k)
          IF(I==2) then                !doubling exit angle if second half
             CALL FACE(EL,BN,H2,X,k)
             x(1)=x(1)+EL%LC*SIN((EL%EDGE(2)-EL%EDGE(1))*0.5_dp)
             call ROT_XZ(EL%EDGE(2),X,EL%BETA0,DONEITT,k%TIME)
          endif
       ELSE
          IF(I==2) then                !doubling exit angle if second half
             call ROT_XZ(EL%EDGE(2),X,EL%BETA0,DONEITT,k%TIME)
             x(1)=x(1)+EL%DIR*EL%LC*SIN((EL%EDGE(2)-EL%EDGE(1))*0.5_dp)
             CALL FACE(EL,BN,H2,X,k)
          endif
          CALL FRINGE_dipole(EL,BN,FINT,HGAP,I,X,k)
          IF(I==1) then                !doubling entrance angle if first half  (1/2 magnet for designer)
             CALL FACE(EL,BN,H1,X,k)
             call ROT_XZ(EL%EDGE(1),X,EL%BETA0,DONEITT,k%TIME)
          endif
       ENDIF
    ELSE
       WRITE(6,*) "ERROR 778"
       STOP 778

    ENDIF


  END SUBROUTINE EDGE_TRUE_PARALLELP

  SUBROUTINE EDGER(EL,BN,H1,H2,FINT,HGAP,I,X,k)
    IMPLICIT NONE
    logical(lp) :: doneitt=.true.
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN)::FINT,HGAP,H1,H2
    real(dp),INTENT(IN),dimension(:)::BN
    TYPE(MAGNET_CHART),INTENT(IN):: EL
    INTEGER, INTENT(IN) :: I
    real(dp) c3,fsad
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(EL%EXACT) THEN
       IF(EL%DIR==1) THEN
          IF(I==1) then                !doubling entrance angle if first half  (1/2 magnet for designer)
             call ROT_XZ(EL%EDGE(1),X,EL%BETA0,DONEITT,k%TIME)
             CALL FACE(EL,BN,H1,X,k)
          endif
          CALL FRINGE_dipole(EL,BN,FINT,HGAP,I,X,k)
          IF(I==2) then                !doubling exit angle if second half
             CALL FACE(EL,BN,H2,X,k)
             x(1)=x(1)+EL%LC*SIN((EL%EDGE(2)-EL%EDGE(1))*0.5_dp)
             call ROT_XZ(EL%EDGE(2),X,EL%BETA0,DONEITT,k%TIME)
          endif
       ELSE
          IF(I==2) then                !doubling exit angle if second half
             call ROT_XZ(EL%EDGE(2),X,EL%BETA0,DONEITT,k%TIME)
             x(1)=x(1)+EL%DIR*EL%LC*SIN((EL%EDGE(2)-EL%EDGE(1))*0.5_dp)
             CALL FACE(EL,BN,H2,X,k)
          endif
          CALL FRINGE_dipole(EL,BN,FINT,HGAP,I,X,k)
          IF(I==1) then                !doubling entrance angle if first half  (1/2 magnet for designer)
             CALL FACE(EL,BN,H1,X,k)
             call ROT_XZ(EL%EDGE(1),X,EL%BETA0,DONEITT,k%TIME)
          endif
       ENDIF
    ELSE

       IF(EL%DIR==1) THEN
          IF(I==2) CALL FACE(EL%DIR*EL%CHARGE,BN,H2,EL%EDGE(2),X,k)
       ELSE
          IF(I==1) then
           CALL FACE(EL%DIR*EL%CHARGE,BN,H1,EL%EDGE(1),X,k)

          ENDIF
       ENDIF

       if(el%b0/=0.0_dp) then
                
          X(2)=X(2)+TAN(EL%EDGE(I))*EL%DIR*EL%CHARGE*BN(1)*X(1)   ! SECTOR WEDGE

          IF(EL%BEND_FRINGE.and.(.NOT.((I==1.AND.EL%KILL_ENT_FRINGE).OR.(I==2.AND.EL%KILL_EXI_FRINGE)))) THEN
 
             X(4)=X(4)-TAN(EL%EDGE(I)-EL%DIR*EL%CHARGE*2.0_dp*FINT*HGAP*(1.0_dp+SIN(EL%EDGE(I))**2)*BN(1)/COS(EL%EDGE(I))) &
                   & *EL%DIR*EL%CHARGE*BN(1)*X(3)   ! SECTOR WEDGE (PROT) + FRINGE
 
!!! coming to you with sadistic delight

                 fsad=0.0_dp
                 if(fint*hgap/=0.0_dp) then
                        fsad=1.d0/(fint*hgap*2)/36.0_dp
                 endif
                 c3=bn(1)**2*fsad 
                 x(4)=x(4)-4*c3*x(3)**3

          ENDIF

       else
          IF(EL%BEND_FRINGE.and.(.NOT.((I==1.AND.EL%KILL_ENT_FRINGE).OR.(I==2.AND.EL%KILL_EXI_FRINGE)))) THEN
 
             CALL FRINGE_dipole(EL,BN,FINT,HGAP,I,X,k)
 
                 fsad=0.0_dp
                 if(fint*hgap/=0.0_dp) then
                        fsad=1.d0/(fint*hgap*2)/36.0_dp
                 endif
                 c3=bn(1)**2*fsad 
                 x(4)=x(4)-4*c3*x(3)**3
          endif

       endif

       IF(EL%DIR==1) THEN
          IF(I==1) CALL FACE(EL%DIR*EL%CHARGE,BN,H1,EL%EDGE(1),X,k)
       ELSE
          IF(I==2) THEN 
         endif
           CALL FACE(EL%DIR*EL%CHARGE,BN,H2,EL%EDGE(2),X,k)
          ENDIF

    ENDIF

  END SUBROUTINE EDGER

  SUBROUTINE EDGEP(EL,BN,H1,H2,FINT,HGAP,I,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN)::FINT,HGAP,H1,H2
    TYPE(REAL_8),INTENT(IN),dimension(:)::BN
    TYPE(MAGNET_CHART),INTENT(IN):: EL
    INTEGER, INTENT(IN) :: I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    TYPE(REAL_8) fsad,c3
integer :: kkk=0
    IF(EL%EXACT) THEN
       IF(EL%DIR==1) THEN
          IF(I==1) then                !doubling entrance angle if first half  (1/2 magnet for designer)
             !   call ROT_XZ(EL%EDGE(1),X,EL%BETA0,DONEITT,k%TIME)       !DONE IN TRUE_PARALLEL ROUTINE!!!!!
             CALL FACE(EL,BN,H1,X,k)
          endif
          CALL FRINGE_dipole(EL,BN,FINT,HGAP,I,X,k)
          IF(I==2) then                !doubling exit angle if second half
             CALL FACE(EL,BN,H2,X,k)
             !   x(1)=x(1)+EL%LC*SIN((EL%EDGE(2)-EL%EDGE(1))*half)
             !   call ROT_XZ(EL%EDGE(2),X,EL%BETA0,DONEITT,k%TIME)
          endif
       ELSE
          IF(I==2) then                !doubling exit angle if second half
             !   call ROT_XZ(EL%EDGE(2),X,EL%BETA0,DONEITT,k%TIME)
             !   x(1)=x(1)+EL%DIR*EL%LC*SIN((EL%EDGE(2)-EL%EDGE(1))*half)
             CALL FACE(EL,BN,H2,X,k)
          endif
          CALL FRINGE_dipole(EL,BN,FINT,HGAP,I,X,k)
          IF(I==1) then                !doubling entrance angle if first half  (1/2 magnet for designer)
             CALL FACE(EL,BN,H1,X,k)
             !   call ROT_XZ(EL%EDGE(1),X,EL%BETA0,DONEITT,k%TIME)
          endif
       ENDIF
    ELSE

       IF(EL%DIR==1) THEN
          IF(I==2) CALL FACE(EL%DIR*EL%CHARGE,BN,H2,EL%EDGE(2),X,k)
       ELSE
          IF(I==1) then
           CALL FACE(EL%DIR*EL%CHARGE,BN,H1,EL%EDGE(1),X,k)

          ENDIF
       ENDIF

       if(el%b0/=0.0_dp) then
          X(2)=X(2)+TAN(EL%EDGE(I))*EL%DIR*EL%CHARGE*BN(1)*X(1)   ! SECTOR WEDGE

          IF(EL%BEND_FRINGE.and.(.NOT.((I==1.AND.EL%KILL_ENT_FRINGE).OR.(I==2.AND.EL%KILL_EXI_FRINGE)))) THEN
 
             X(4)=X(4)-TAN(EL%EDGE(I)-EL%DIR*EL%CHARGE*2.0_dp*FINT*HGAP*(1.0_dp+SIN(EL%EDGE(I))**2)*BN(1)/COS(EL%EDGE(I))) &
                   & *EL%DIR*EL%CHARGE*BN(1)*X(3)   ! SECTOR WEDGE (PROT) + FRINGE
 
!!! coming to you with sadistic delight
            call alloc(fsad,c3)
                 fsad=0.0_dp
                 if(fint*hgap/=0.0_dp) then
                        fsad=1.d0/(fint*hgap*2)/36.0_dp
                 endif
                 c3=bn(1)**2*fsad 
                 x(4)=x(4)-4*c3*x(3)**3
            call kill(fsad,c3)
          ENDIF

       else
          IF(EL%BEND_FRINGE.and.(.NOT.((I==1.AND.EL%KILL_ENT_FRINGE).OR.(I==2.AND.EL%KILL_EXI_FRINGE)))) THEN
 
             CALL FRINGE_dipole(EL,BN,FINT,HGAP,I,X,k)
 
                 fsad=0.0_dp
                 if(fint*hgap/=0.0_dp) then
                        fsad=1.d0/(fint*hgap*2)/36.0_dp
                 endif
                 c3=bn(1)**2*fsad 
                 x(4)=x(4)-4*c3*x(3)**3
          endif
       endif


       IF(EL%DIR==1) THEN
          IF(I==1) CALL FACE(EL%DIR*EL%CHARGE,BN,H1,EL%EDGE(1),X,k)
       ELSE
          IF(I==2) THEN 
           CALL FACE(EL%DIR*EL%CHARGE,BN,H2,EL%EDGE(2),X,k)
          ENDIF
       ENDIF



    ENDIF


  END SUBROUTINE EDGEP

  SUBROUTINE KICKR(EL,YL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(DKD2),INTENT(IN):: EL
    real(dp),INTENT(IN):: YL
    real(dp) X1,X3,X5,BBYTW,BBXTW,BBYTWT
    INTEGER J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir


    DIR=EL%P%DIR*EL%P%CHARGE

    X1=X(1)
    X3=X(3)

    if(k%TIME) then
       X5=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)-1.0_dp
    else
       X5=X(5)
    endif

    IF(EL%P%NMUL>=1) THEN
       BBYTW=EL%BN(EL%P%NMUL)
       BBXTW=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,1,-1
          BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
          BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
          BBYTW=BBYTWT
       ENDDO
    ELSE
       BBYTW=0.0_dp
       BBXTW=0.0_dp
    ENDIF


    IF(EL%P%EXACT) THEN
       X(2)=X(2)-YL*DIR*BBYTW
       X(4)=X(4)+YL*DIR*BBXTW
    ELSE
       !  for sixtrack comparison
       !          X(2)=X(2)-EL%thin_h_foc*x1*HALF +EL%P%DIR*EL%P%CHARGE*EL%thin_h_angle*(PZ-one)*HALF  ! highly illegal additions by frs
       !          X(4)=X(4)-EL%thin_v_foc*x3*HALF +EL%P%DIR*EL%P%CHARGE*EL%thin_v_angle*(PZ-one)*HALF  ! highly illegal additions by frs
       !          X(6)=X(6)+EL%P%DIR*EL%P%CHARGE*(EL%thin_h_angle*x1+EL%thin_v_angle*x3)*(one/EL%P%BETA0+x(5))/pz*HALF
       X(2)=X(2)-YL*(DIR*BBYTW-EL%P%B0-(X5-X1*DIR*EL%BN(1))*EL%P%B0)
       X(4)=X(4)+YL* DIR*BBXTW

       if(k%TIME) then
          X(6)=X(6)+YL*EL%P%B0*X1*(1.0_dp/EL%P%beta0+x(5))/(1.0_dp+X5)
       else
          X(6)=X(6)+YL*EL%P%B0*X1
       endif
    ENDIF

    !outvalishev    if(valishev.and.ABS(el%VS)>eps)   then  !valishev
    !outvalishev     call elliptical_b(el%VA,el%VS,x,BBXTW,BBYTW) !valishev
    !outvalishev       X(2)=X(2)-YL*DIR*BBYTW !valishev
    !outvalishev       X(4)=X(4)+YL* DIR*BBXTW !valishev
    !outvalishev    endif !valishev

  END SUBROUTINE KICKR

  SUBROUTINE KICKP(EL,YL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(DKD2P),INTENT(IN):: EL
    TYPE(REAL_8),INTENT(IN):: YL
    TYPE(REAL_8) X1,X3,X5,BBYTW,BBXTW,BBYTWT
    INTEGER J,DIR
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    CALL ALLOC(X1)
    CALL ALLOC(X3)
    CALL ALLOC(X5)
    CALL ALLOC(BBYTW)
    CALL ALLOC(BBXTW)
    CALL ALLOC(BBYTWT)

    DIR=EL%P%DIR*EL%P%CHARGE
    X1=X(1)
    X3=X(3)

    if(k%TIME) then
       X5=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)-1.0_dp
    else
       X5=X(5)
    endif

    IF(EL%P%NMUL>=1) THEN
       BBYTW=EL%BN(EL%P%NMUL)
       BBXTW=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,1,-1
          BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
          BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
          BBYTW=BBYTWT
       ENDDO
    ELSE
       BBYTW=0.0_dp
       BBXTW=0.0_dp
    ENDIF


    IF(EL%P%EXACT) THEN
       X(2)=X(2)-YL*DIR*BBYTW
       X(4)=X(4)+YL*DIR*BBXTW
    ELSE
       X(2)=X(2)-YL*(DIR*BBYTW-EL%P%B0-(X5-X1*DIR*EL%BN(1))*EL%P%B0)
       X(4)=X(4)+YL* DIR*BBXTW

       if(k%TIME) then
          X(6)=X(6)+YL*EL%P%B0*X1*(1.0_dp/EL%P%beta0+x(5))/(1.0_dp+X5)
       else
          X(6)=X(6)+YL*EL%P%B0*X1
       endif
    ENDIF

    !outvalishev    if(valishev.and.ABS(el%VS)>eps)   then  !valishev
    !outvalishev     call elliptical_b(el%VA,el%VS,x,BBXTW,BBYTW) !valishev
    !outvalishev       X(2)=X(2)-YL*DIR*BBYTW !valishev
    !outvalishev       X(4)=X(4)+YL* DIR*BBXTW !valishev
    !outvalishev    endif !valishev


    CALL KILL(X1)
    CALL KILL(X3)
    CALL KILL(X5)
    CALL KILL(BBYTW)
    CALL KILL(BBXTW)
    CALL KILL(BBYTWT)

  END SUBROUTINE KICKP

  SUBROUTINE INTER_dkd2 (EL,X,k,pos)
    IMPLICIT NONE
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(DKD2),INTENT(IN):: EL
    INTEGER pos
    real(dp) D,DH,DD
    real(dp) D1,D2,DK1,DK2
    real(dp) DD1,DD2
    real(dp) DF(4),DK(4),DDF(4)
    INTEGER I,J,f1
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    SELECT CASE(EL%P%METHOD)
    CASE(1)
       if(EL%F==1) then
          f1=0
       else
          f1=EL%F+1
       endif
       DH=EL%L/EL%P%NST
       D=EL%L/(EL%P%NST/EL%F/2)
       DD=EL%P%LD/EL%P%NST

       IF(MOD(POS,2*EL%F)==f1) THEN
          CALL KICK (EL,D,X,k)
       ENDIF
       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)

    CASE(2)
       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       DD=EL%P%LD/2.0_dp/EL%P%NST




       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICK (EL,D,X,k)
       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)



    CASE(4)
       D1=EL%L*FD1/EL%P%NST
       D2=EL%L*FD2/EL%P%NST
       DD1=EL%P%LD*FD1/EL%P%NST
       DD2=EL%P%LD*FD2/EL%P%NST
       DK1=EL%L*FK1/EL%P%NST
       DK2=EL%L*FK2/EL%P%NST




       CALL DRIFT(D1,DD1,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICK (EL,DK1,X,k)
       CALL DRIFT(D2,DD2,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICK (EL,DK2,X,k)

       CALL DRIFT(D2,DD2,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICK (EL,DK1,X,k)
       CALL DRIFT(D1,DD1,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)



    CASE(6)
       DO I =1,4
          DF(I)=EL%L*YOSD(I)/EL%P%NST
          DDF(I)=EL%P%LD*YOSD(I)/EL%P%NST
          DK(I)=EL%L*YOSK(I)/EL%P%NST
       ENDDO

       !       DO I=1,B%N

       !        X=BEAM_IN_X(B,I)

       DO J=4,2,-1
          CALL DRIFT(DF(J),DDF(J),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICK (EL,DK(J),X,k)
       ENDDO
       CALL DRIFT(DF(1),DDF(1),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICK (EL,DK(1),X,k)

       CALL DRIFT(DF(1),DDF(1),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       DO J=2,4
          CALL KICK (EL,DK(J),X,k)
          CALL DRIFT(DF(J),DDF(J),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       ENDDO




    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

  END SUBROUTINE INTER_dkd2

  SUBROUTINE INTEP_dkd2 (EL,X,k,pos)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(DKD2P),INTENT(IN):: EL

    real(dp) DD
    real(dp) DD1,DD2
    real(dp) DDF(4)
    TYPE(REAL_8) DH,D,D1,D2,DK1,DK2,DF(4),DK(4)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    INTEGER I,J,pos,f1

    SELECT CASE(EL%P%METHOD)

    CASE(1)
       if(EL%F==1) then
          f1=0
       else
          f1=EL%F+1
       endif
       CALL ALLOC(DH,D)
       DH=EL%L/EL%P%NST
       D=EL%L/(EL%P%NST/EL%F/2)
       DD=EL%P%LD/EL%P%NST

       IF(MOD(POS,2*EL%F)==f1) THEN
          CALL KICK (EL,D,X,k)
       ENDIF
       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KILL(DH,D)

    CASE(2)
       CALL ALLOC(DH,D)
       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       DD=EL%P%LD/2.0_dp/EL%P%NST

       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICK (EL,D,X,k)
       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)

       CALL KILL(DH,D)

    CASE(4)
       CALL ALLOC(D1,D2,DK1,DK2)
       D1=EL%L*FD1/EL%P%NST
       D2=EL%L*FD2/EL%P%NST
       DD1=EL%P%LD*FD1/EL%P%NST
       DD2=EL%P%LD*FD2/EL%P%NST
       DK1=EL%L*FK1/EL%P%NST
       DK2=EL%L*FK2/EL%P%NST



       CALL DRIFT(D1,DD1,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICK (EL,DK1,X,k)
       CALL DRIFT(D2,DD2,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICK (EL,DK2,X,k)

       CALL DRIFT(D2,DD2,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICK (EL,DK1,X,k)
       CALL DRIFT(D1,DD1,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)

       CALL KILL(D1,D2,DK1,DK2)


    CASE(6)
       CALL ALLOC(DF,4);CALL ALLOC(DK,4);
       DO I =1,4
          DF(I)=EL%L*YOSD(I)/EL%P%NST
          DDF(I)=EL%P%LD*YOSD(I)/EL%P%NST
          DK(I)=EL%L*YOSK(I)/EL%P%NST
       ENDDO

       !       DO I=1,B%N

       !        X=BEAM_IN_X(B,I)

       DO J=4,2,-1
          CALL DRIFT(DF(J),DDF(J),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICK (EL,DK(J),X,k)
       ENDDO
       CALL DRIFT(DF(1),DDF(1),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICK (EL,DK(1),X,k)

       CALL DRIFT(DF(1),DDF(1),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       DO J=2,4
          CALL KICK (EL,DK(J),X,k)
          CALL DRIFT(DF(J),DDF(J),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       ENDDO


       CALL KILL(DF,4);CALL KILL(DK,4);


    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

  END SUBROUTINE INTEP_dkd2

  SUBROUTINE INTER(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(DKD2),INTENT(IN):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    DO I=1,EL%P%NST
       IF(.NOT.PRESENT(MID)) CALL TRACK_SLICE(EL,X,k,i)
       IF(PRESENT(MID)) CALL XMID(MID,X,I)
    ENDDO

  END SUBROUTINE INTER





  SUBROUTINE INTEP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    ! TYPE(WORM_8),OPTIONAL,INTENT(INOUT):: MID
    TYPE(DKD2P),INTENT(IN):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    DO I=1,EL%P%NST
       CALL TRACK_SLICE(EL,X,k,i)
    ENDDO

  END SUBROUTINE INTEP

  SUBROUTINE SYMPINTR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(DKD2),INTENT(IN):: EL
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(.NOT.PRESENT(MID)) CALL TRACK_FRINGE(EL=EL,X=X,k=k,J=1)
    CALL INTE(EL,X,k,MID)
    IF(.NOT.PRESENT(MID)) CALL TRACK_FRINGE(EL=EL,X=X,k=k,J=2)

  END SUBROUTINE SYMPINTR

  SUBROUTINE SYMPINTP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(DKD2P),INTENT(IN):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL TRACK_FRINGE(EL=EL,X=X,k=k,J=1)
    CALL INTE(EL,X,k)
    CALL TRACK_FRINGE(EL=EL,X=X,k=k,J=2)


  END SUBROUTINE SYMPINTP



  SUBROUTINE KICK_SOLR(EL,YL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(SOL5),INTENT(IN):: EL
    real(dp),INTENT(IN):: YL
    real(dp)  bsol,ang,xp,yp,h,c,sh,yh,xt(4),dl
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    integer i



    bsol=EL%B_SOL*EL%P%CHARGE
    xp=x(2)+bsol*x(3)/2.0_dp
    yp=x(4)-bsol*x(1)/2.0_dp

    ! NO EXACT EL%EXACT
    if(EL%p%exact) then
       if(k%TIME) then
          h=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2-xp**2-yp**2)
          dl=1.0_dp
       else
          h=ROOT((1.0_dp+x(5))**2-xp**2-yp**2)
          dl=1.0_dp
       endif
    else
       if(k%TIME) then
          h=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
          dl=1.0_dp+(xp**2+yp**2)/2.0_dp/h**2
       else
          h=1.0_dp+x(5)
          dl=1.0_dp+(xp**2+yp**2)/2.0_dp/h**2
       endif
    endif
    yh=yl/h
    c=cos(yh*bsol/2.0_dp)
    sh=SINX_X(yh*bsol/2.0_dp)

    xt(1)=c*x(1)+yh*sh*x(2)
    xt(2)=c*x(2)-yh*bsol**2*sh*x(1)/4.0_dp
    xt(3)=c*x(3)+yh*sh*x(4)
    xt(4)=c*x(4)-yh*bsol**2*sh*x(3)/4.0_dp

    DO I=1,4
       X(I)=XT(I)
    ENDDO

    ANG=Yh*EL%B_SOL*EL%P%CHARGE/2.0_dp

    c=COS(ANG)
    sh=SIN(ANG)
    ! NO EXACT EL%EXACT

    XT(1)=c*X(1)+sh*X(3)
    XT(2)=c*X(2)+sh*X(4)
    XT(3)=c*X(3)-sh*X(1)
    XT(4)=c*X(4)-sh*X(2)

    DO I=1,4
       X(I)=XT(I)
    ENDDO


    if(k%TIME) then
       x(6)=x(6)+yl*dl*(1.0_dp/EL%P%beta0+X(5))/h-(1-k%totalpath)*yl/EL%P%beta0
    else
       x(6)=x(6)+yl*dl*(1.0_dp+X(5))/h-(1-k%totalpath)*yl
    endif



  END SUBROUTINE KICK_SOLR

  SUBROUTINE KICK_SOLP(EL,YL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(SOL5P),INTENT(IN):: EL
    TYPE(REAL_8),INTENT(IN):: YL
    TYPE(REAL_8)  BSOL,xp,yp,h,yh,xt(4),sh,c,ang,dl
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    integer i

    CALL ALLOC(BSOL,xp,yp,h,yh,sh,c,ang,dl)
    CALL ALLOC(xt,4)

    bsol=EL%B_SOL*EL%P%CHARGE
    xp=x(2)+bsol*x(3)/2.0_dp
    yp=x(4)-bsol*x(1)/2.0_dp

    ! NO EXACT EL%EXACT
    if(EL%p%exact) then
       if(k%TIME) then
          h=sqrt(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2-xp**2-yp**2)
          dl=1.0_dp
       else
          h=sqrt((1.0_dp+x(5))**2-xp**2-yp**2)
          dl=1.0_dp
       endif
    else
       if(k%TIME) then
          h=sqrt(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
          dl=1.0_dp+(xp**2+yp**2)/2.0_dp/h**2
       else
          h=1.0_dp+x(5)
          dl=1.0_dp+(xp**2+yp**2)/2.0_dp/h**2
       endif
    endif
    yh=yl/h
    c=cos(yh*bsol/2.0_dp)
    sh=SINX_X(yh*bsol/2.0_dp)

    xt(1)=c*x(1)+yh*sh*x(2)
    xt(2)=c*x(2)-yh*bsol**2*sh*x(1)/4.0_dp
    xt(3)=c*x(3)+yh*sh*x(4)
    xt(4)=c*x(4)-yh*bsol**2*sh*x(3)/4.0_dp

    DO I=1,4
       X(I)=XT(I)
    ENDDO

    ANG=Yh*EL%B_SOL*EL%P%CHARGE/2.0_dp

    c=COS(ANG)
    sh=SIN(ANG)
    ! NO EXACT EL%EXACT

    XT(1)=c*X(1)+sh*X(3)
    XT(2)=c*X(2)+sh*X(4)
    XT(3)=c*X(3)-sh*X(1)
    XT(4)=c*X(4)-sh*X(2)

    DO I=1,4
       X(I)=XT(I)
    ENDDO


    if(k%TIME) then
       x(6)=x(6)+yl*dl*(1.0_dp/EL%P%beta0+X(5))/h-(1-k%totalpath)*yl/EL%P%beta0
    else
       x(6)=x(6)+yl*dl*(1.0_dp+X(5))/h-(1-k%totalpath)*yl
    endif



    CALL kill(xt,4)
    CALL kill(BSOL,xp,yp,h,yh,sh,c,ang,dl)

  END SUBROUTINE KICK_SOLP

  SUBROUTINE GETNEWBR(an,bn,b_sol,nmul,B,X)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6),B(3)
    real(dp),INTENT(IN):: an(:),bn(:),b_sol
    integer,INTENT(IN):: nmul
    real(dp) X1,X3,BBYTW,BBXTW,BBYTWT
    INTEGER J

    X1=X(1)
    X3=X(3)

    IF(NMUL>=1) THEN
       BBYTW=BN(NMUL)
       BBXTW=AN(NMUL)

       DO  J=NMUL-1,1,-1
          BBYTWT=X1*BBYTW-X3*BBXTW+BN(J)
          BBXTW=X3*BBYTW+X1*BBXTW+AN(J)
          BBYTW=BBYTWT
       ENDDO
    ELSE
       BBYTW=0.0_dp
       BBXTW=0.0_dp
    ENDIF
    B(1)=BBXTW;B(2)=BBYTW;B(3)=B_SOL;

  END SUBROUTINE GETNEWBR

  SUBROUTINE GETNEWBP(an,bn,b_sol,nmul,B,X)
    IMPLICIT NONE
    type(REAL_8),INTENT(INOUT):: X(6),B(3)
    type(REAL_8),INTENT(IN):: an(:),bn(:),b_sol
    integer,INTENT(IN):: nmul
    type(REAL_8) X1,X3,BBYTW,BBXTW,BBYTWT
    INTEGER J
    CALL ALLOC(X1,X3,BBYTW,BBXTW,BBYTWT)
    X1=X(1)
    X3=X(3)

    IF(NMUL>=1) THEN
       BBYTW=BN(NMUL)
       BBXTW=AN(NMUL)

       DO  J=NMUL-1,1,-1
          BBYTWT=X1*BBYTW-X3*BBXTW+BN(J)
          BBXTW=X3*BBYTW+X1*BBXTW+AN(J)
          BBYTW=BBYTWT
       ENDDO
    ELSE
       BBYTW=0.0_dp
       BBXTW=0.0_dp
    ENDIF
    B(1)=BBXTW;B(2)=BBYTW;B(3)=B_SOL;

    CALL kill(X1,X3,BBYTW,BBXTW,BBYTWT)

  END SUBROUTINE GETNEWBP

  SUBROUTINE GETMULB_SOLR(EL,B,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6),B(3)
    TYPE(SOL5),INTENT(IN):: EL
    real(dp) X1,X3,BBYTW,BBXTW,BBYTWT
    INTEGER J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    x(1)=x(1)-el%dx
    x(3)=x(3)-el%dy
    call GETNEWB(el%an,el%bn,el%b_sol,EL%P%NMUL,B,X)
    x(1)=x(1)+el%dx
    x(3)=x(3)+el%dy


    !outvalishev    if(valishev.and.ABS(el%VS)>eps)   then  !valishev
    !outvalishev     call elliptical_b(el%VA,el%VS,x,BBXTW,BBYTW) !valishev
    !outvalishev     B(1)=B(1)+BBXTW; B(2)=B(2)+BBYTW;
    !outvalishev    endif !valishev

  END SUBROUTINE GETMULB_SOLR

  SUBROUTINE GETMULB_SOLP(EL,B,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6),B(3)
    TYPE(SOL5P),INTENT(IN):: EL

    INTEGER J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    x(1)=x(1)-el%dx
    x(3)=x(3)-el%dy
    call GETNEWB(el%an,el%bn,el%b_sol,EL%P%NMUL,B,X)
    x(1)=x(1)+el%dx
    x(3)=x(3)+el%dy


  END SUBROUTINE GETMULB_SOLP

  SUBROUTINE KICKMULR(EL,YL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(SOL5),INTENT(IN):: EL
    real(dp),INTENT(IN):: YL
    real(dp) B(3)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL GETMULB_SOL(EL,B,X,k)

    X(2)=X(2)-YL*EL%P%DIR*EL%P%CHARGE*B(2)
    X(4)=X(4)+YL*EL%P%DIR*EL%P%CHARGE*B(1)

  END SUBROUTINE KICKMULR

  SUBROUTINE KICKMULP(EL,YL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(SOL5P),INTENT(IN):: EL
    TYPE(REAL_8),INTENT(IN):: YL
    TYPE(REAL_8) B(3)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ALLOC(B,3)

    CALL GETMULB_SOL(EL,B,X,k)

    X(2)=X(2)-YL*EL%P%DIR*EL%P%CHARGE*B(2)
    X(4)=X(4)+YL*EL%P%DIR*EL%P%CHARGE*B(1)

    CALL KILL(B,3)

  END SUBROUTINE KICKMULP




  SUBROUTINE INTER_SOL5(EL,X,k)
    IMPLICIT NONE
    real(dp), INTENT(INOUT) ::  X(6)
    TYPE(SOL5),INTENT(IN):: EL

    real(dp) D,DH,DD
    real(dp) D1,D2,DK1,DK2,D2H
    real(dp) dd1,dd2,DK(4),DF(4),DDF(4)
    INTEGER I,J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K




    SELECT CASE(EL%P%METHOD)
    CASE(2)
       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       DD=(EL%P%LD)/2.0_dp/EL%P%NST


       CALL KICK_SOL(EL,DH,X,k)
       CALL KICKMUL(EL,D,X,k)
       CALL KICK_SOL(EL,DH,X,k)


    CASE(4)

       D=EL%L/EL%P%NST
       D1=D*FD1
       D2=D*FD2
       DK1=D*FK1
       DK2=D*FK2
       D2H=DK2/2.0_dp
       DD1=(EL%P%LD)/EL%P%NST*FD1
       DD2=(EL%P%LD)/EL%P%NST*FD2

       CALL KICK_SOL(EL,D1,X,k)
       CALL KICKMUL(EL,DK1,X,k)
       CALL KICK_SOL(EL,D1,X,k)
       CALL KICK_SOL(EL,D2H,X,k)
       CALL KICKMUL(EL,DK2,X,k)
       CALL KICK_SOL(EL,D2H,X,k)
       CALL KICK_SOL(EL,D1,X,k)
       CALL KICKMUL(EL,DK1,X,k)
       CALL KICK_SOL(EL,D1,X,k)



    CASE(6)
       DO I =1,4
          DK(I)=EL%L*YOSK(I)/EL%P%NST
          DF(I)=DK(I)/2.0_dp
          DDF(I)=EL%P%LD*YOSK(I)/2.0_dp/EL%P%NST
       ENDDO

       !       DO I=1,B%N

       !        X=BEAM_IN_X(B,I)
       DO J=4,1,-1
          CALL KICK_SOL(EL,DF(J),X,k)
          CALL KICKMUL(EL,DK(J),X,k)
          CALL KICK_SOL(EL,DF(J),X,k)
       ENDDO

       DO J=2,4
          CALL KICK_SOL(EL,DF(J),X,k)
          CALL KICKMUL(EL,DK(J),X,k)
          CALL KICK_SOL(EL,DF(J),X,k)
       ENDDO


    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT



  END SUBROUTINE INTER_SOL5

  SUBROUTINE INTEP_SOL5(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) ::  X(6)
    TYPE(SOL5P),INTENT(IN):: EL

    real(dp) DD
    real(dp) DD1,DD2
    real(dp) DDF(4)
    TYPE(REAL_8) DH,D,D1,D2,DK1,DK2,DF(4),DK(4),D2H
    INTEGER I,J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K




    SELECT CASE(EL%P%METHOD)
    CASE(2)
       CALL ALLOC(DH,D)
       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       DD=(EL%P%LD)/2.0_dp/EL%P%NST


       CALL KICK_SOL(EL,DH,X,k)
       CALL KICKMUL(EL,D,X,k)
       CALL KICK_SOL(EL,DH,X,k)
       CALL KILL(DH,D)


    CASE(4)
       CALL ALLOC(D1,D2,DK1,DK2,D2H)

       D=EL%L/EL%P%NST
       D1=D*FD1
       D2=D*FD2
       DK1=D*FK1
       DK2=D*FK2
       D2H=DK2/2.0_dp
       DD1=(EL%P%LD)/EL%P%NST*FD1
       DD2=(EL%P%LD)/EL%P%NST*FD2

       CALL KICK_SOL(EL,D1,X,k)
       CALL KICKMUL(EL,DK1,X,k)
       CALL KICK_SOL(EL,D1,X,k)
       CALL KICK_SOL(EL,D2H,X,k)
       CALL KICKMUL(EL,DK2,X,k)
       CALL KICK_SOL(EL,D2H,X,k)
       CALL KICK_SOL(EL,D1,X,k)
       CALL KICKMUL(EL,DK1,X,k)
       CALL KICK_SOL(EL,D1,X,k)

       CALL KILL(D1,D2,DK1,DK2,D2H)


    CASE(6)
       CALL ALLOC(DF,4);CALL ALLOC(DK,4);
       DO I =1,4
          DK(I)=EL%L*YOSK(I)/EL%P%NST
          DF(I)=DK(I)/2.0_dp
          DDF(I)=EL%P%LD*YOSK(I)/2.0_dp/EL%P%NST
       ENDDO

       !       DO I=1,B%N

       !        X=BEAM_IN_X(B,I)
       DO J=4,1,-1
          CALL KICK_SOL(EL,DF(J),X,k)
          CALL KICKMUL(EL,DK(J),X,k)
          CALL KICK_SOL(EL,DF(J),X,k)
       ENDDO

       DO J=2,4
          CALL KICK_SOL(EL,DF(J),X,k)
          CALL KICKMUL(EL,DK(J),X,k)
          CALL KICK_SOL(EL,DF(J),X,k)
       ENDDO

       CALL KILL(DF,4);CALL KILL(DK,4);

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

  END SUBROUTINE INTEP_SOL5


  SUBROUTINE INTESOLR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: mid
    TYPE(SOL5),INTENT(IN):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    IF(PRESENT(MID)) CALL XMID(MID,X,0)


    DO I=1,EL%P%NST

       IF(.NOT.PRESENT(MID)) CALL TRACK_SLICE(EL,X,k)
       IF(PRESENT(MID)) CALL XMID(MID,X,I)
    ENDDO

  END SUBROUTINE INTESOLR

  SUBROUTINE INTESOLP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(SOL5P),INTENT(IN):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    INTEGER I

    DO I=1,EL%P%NST
       CALL TRACK_SLICE(EL,X,k)
    ENDDO

  END SUBROUTINE INTESOLP

  SUBROUTINE SYMPINTSOLR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(SOL5),INTENT(INOUT):: EL
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: mid
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(.NOT.PRESENT(MID)) CALL TRACK_FRINGE(EL5=EL,X=X,k=k,J=1)
    CALL INTESOL(EL,X,k,MID)
    IF(.NOT.PRESENT(MID)) CALL TRACK_FRINGE(EL5=EL,X=X,k=k,J=2)

  END SUBROUTINE SYMPINTSOLR

  SUBROUTINE SYMPINTSOLP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(SOL5P),INTENT(INOUT):: EL
    ! TYPE(WORM_8),OPTIONAL,INTENT(INOUT):: mid
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL TRACK_FRINGE(EL5=EL,X=X,k=k,J=1)
    CALL INTESOL(EL,X,k)
    CALL TRACK_FRINGE(EL5=EL,X=X,k=k,J=2)

  END SUBROUTINE SYMPINTSOLP


!!!! *************************************************************** !!!!
!!!! *           Beginning of the slow thick element               * !!!!
!!!! *************************************************************** !!!!







!!!! *************************************************************** !!!!
!!!! *           Beginning of the slow thick element               * !!!!
!!!! *************************************************************** !!!!

  SUBROUTINE GETMATR(EL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(KTK),INTENT(INOUT):: EL
    real(dp) HX(3,3),HY(3,3),HL(6,6),V(6),W(6)
    real(dp) DH,X5,X6
    INTEGER I,J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    DIR=EL%P%DIR*EL%P%CHARGE


    IF(EL%P%METHOD==2.AND.OLD_IMPLEMENTATION_OF_SIXTRACK) THEN
       DH=EL%L/EL%P%NST
    ELSE
       IF(EL%P%METHOD/=6) THEN
          DH=EL%L/EL%P%NST/2.0_dp
       ELSE
          DH=EL%L/EL%P%NST/4.0_dp
       ENDIF
    ENDIF

    IF(k%TIME) THEN
       X5=ROOT(1.0_dp+2.0_dp*X(5)/el%P%beta0+x(5)**2)-1
    ELSE
       X5=X(5)
    ENDIF

    HX(1,1)=0.0_dp;HX(1,2)=DH/(1.0_dp+X5);HX(1,3)=0.0_dp;
    HX(2,1)=DIR*DH*(-EL%BN(2)-EL%P%B0*EL%BN(1));HX(2,2)=0.0_dp;HX(2,3)=DH*EL%P%B0;
    HX(3,1)=0.0_dp;HX(3,2)=0.0_dp;HX(3,3)=0.0_dp;
    HY(1,1)=0.0_dp;HY(1,2)=HX(1,2);HY(1,3)=0.0_dp;
    HY(2,1)=DH*DIR*EL%BN(2);HY(2,2)=0.0_dp;HY(2,3)=0.0_dp;
    HY(3,1)=0.0_dp;HY(3,2)=0.0_dp;HY(3,3)=0.0_dp;
    CALL EXPCOSY(HX,EL%MATX)
    CALL EXPCOSY(HY,EL%MATY)
    DO I=1,6
       V(I)=0.0_dp
       DO J=1,6
          HL(I,J)=0.0_dp
       ENDDO
    ENDDO
    HL(1,3)=HX(2,3)*X5; HL(2,3)=HX(2,1); HL(3,2)=HX(1,2);
    HL(4,5)=HX(2,1); HL(6,5)=HX(1,2); HL(2,5)=HX(2,3)*X5;
    HL(5,6)=2.0_dp*HX(2,1); HL(3,6)=2.0_dp*HX(2,3)*X5;HL(5,4)=2.0_dp*HX(1,2);
    V(2)=HX(2,3)
    V(6)=HX(1,2)/(1.0_dp+X5)/2.0_dp;
    CALL EXPCOSY6(HL,V,W)
    do i=1,6
       EL%LX(I)=W(I)
    enddo
    DO I=1,6
       V(I)=0.0_dp
       DO J=1,6
          HL(I,J)=0.0_dp
       ENDDO
    ENDDO
    HL(2,3)=HY(2,1); HL(3,2)=HY(1,2);
    HL(4,5)=HY(2,1); HL(6,5)=HY(1,2)
    HL(5,6)=2.0_dp*HY(2,1);HL(5,4)=2.0_dp*HY(1,2);
    V(6)=HY(1,2)/(1.0_dp+X5)/2.0_dp;
    CALL EXPCOSY6(HL,V,W)

    do i=1,3
       EL%LY(I)=W(3+I)
    enddo


    IF(k%TIME) THEN         ! SPECIAL TIME FACTOR
       X6=(X(5)+2.0_dp/EL%P%beta0)/(2.0_dp+X5)              ! DELTA/E
       X5=(1.0_dp/EL%P%beta0+X(5))/(1.0_dp+X5)     ! dDELTA/dE
       EL%MATX(1,3)=EL%MATX(1,3)*X6
       EL%MATX(2,3)=EL%MATX(2,3)*X6
       do i=1,6
          EL%LX(I)=X5*EL%LX(I)
       enddo
       do i=1,3
          EL%LY(I)=X5*EL%LY(I)
       enddo
       ! BUG FOUND BY SCHMIDT
       !       EL%LX(1)=EL%LX(1)+k%TOTALPATH*DH*X5
       EL%LX(1)=EL%LX(1)+DH*X5-(1-k%TOTALPATH)*DH/EL%P%beta0
    ELSE
       EL%LX(1)=EL%LX(1)+k%TOTALPATH*DH
    ENDIF

  END SUBROUTINE GETMATR

  SUBROUTINE GETMATD(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(KTKP),INTENT(INOUT):: EL
    TYPE(REAL_8) HX(3,3),HY(3,3),HL(6,6),V(6),W(6)
    TYPE(REAL_8) DH,X5,X6
    INTEGER I,J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    DIR=EL%P%DIR*EL%P%CHARGE

    DO I=1,3
       DO J=1,3
          CALL ALLOC(HX(I,J));CALL ALLOC(HY(I,J))
       ENDDO
    ENDDO
    DO I=1,6
       CALL ALLOC(V(I));CALL ALLOC(W(I))
       DO J=1,6
          CALL ALLOC(HL(I,J))
       ENDDO
    ENDDO
    CALL ALLOC(DH);CALL ALLOC(X5);CALL ALLOC(X6);
    IF(EL%P%METHOD==2.AND.OLD_IMPLEMENTATION_OF_SIXTRACK) THEN
       DH=EL%L/EL%P%NST
    ELSE
       IF(EL%P%METHOD/=6) THEN
          DH=EL%L/EL%P%NST/2.0_dp
       ELSE
          DH=EL%L/EL%P%NST/4.0_dp
       ENDIF
    ENDIF

    IF(k%TIME) THEN
       X5=SQRT(1.0_dp+2.0_dp*X(5)/el%P%beta0+x(5)**2)-1
    ELSE
       X5=X(5)
    ENDIF
    HX(1,1)=0.0_dp;HX(1,2)=DH/(1.0_dp+X5);HX(1,3)=0.0_dp;
    HX(2,1)=DIR*DH*(-EL%BN(2)-EL%P%B0*EL%BN(1));HX(2,2)=0.0_dp;HX(2,3)=DH*EL%P%B0;
    HX(3,1)=0.0_dp;HX(3,2)=0.0_dp;HX(3,3)=0.0_dp;
    HY(1,1)=0.0_dp;HY(1,2)=HX(1,2);HY(1,3)=0.0_dp;
    HY(2,1)=DH*DIR*EL%BN(2);HY(2,2)=0.0_dp;HY(2,3)=0.0_dp;
    HY(3,1)=0.0_dp;HY(3,2)=0.0_dp;HY(3,3)=0.0_dp;
    CALL EXPCOSY(HX,EL%MATX)
    CALL EXPCOSY(HY,EL%MATY)
    DO I=1,6
       V(I)=0.0_dp
       DO J=1,6
          HL(I,J)=0.0_dp
       ENDDO
    ENDDO
    HL(1,3)=HX(2,3)*X5; HL(2,3)=HX(2,1); HL(3,2)=HX(1,2);
    HL(4,5)=HX(2,1); HL(6,5)=HX(1,2); HL(2,5)=HX(2,3)*X5;
    HL(5,6)=2.0_dp*HX(2,1); HL(3,6)=2.0_dp*HX(2,3)*X5;HL(5,4)=2.0_dp*HX(1,2);
    V(2)=HX(2,3)
    V(6)=HX(1,2)/(1.0_dp+X5)/2.0_dp;
    CALL EXPCOSY6(HL,V,W)
    do i=1,6
       EL%LX(I)=W(I)
    enddo
    DO I=1,6
       V(I)=0.0_dp
       DO J=1,6
          HL(I,J)=0.0_dp
       ENDDO
    ENDDO
    HL(2,3)=HY(2,1); HL(3,2)=HY(1,2);
    HL(4,5)=HY(2,1); HL(6,5)=HY(1,2)
    HL(5,6)=2.0_dp*HY(2,1);HL(5,4)=2.0_dp*HY(1,2);
    V(6)=HY(1,2)/(1.0_dp+X5)/2.0_dp;
    CALL EXPCOSY6(HL,V,W)

    do i=1,3
       EL%LY(I)=W(3+I)
    enddo

    IF(k%TIME) THEN         ! SPECIAL TIME FACTOR
       X6=(X(5)+2.0_dp/EL%P%beta0)/(2.0_dp+X5)              ! DELTA/E
       X5=(1.0_dp/EL%P%beta0+X(5))/(1.0_dp+X5)     ! dDELTA/dE
       EL%MATX(1,3)=EL%MATX(1,3)*X6
       EL%MATX(2,3)=EL%MATX(2,3)*X6
       do i=1,6
          EL%LX(I)=X5*EL%LX(I)
       enddo
       do i=1,3
          EL%LY(I)=X5*EL%LY(I)
       enddo
       ! BUG FOUND BY SCHMIDT
       !       EL%LX(1)=EL%LX(1)+k%TOTALPATH*DH*X5
       EL%LX(1)=EL%LX(1)+DH*X5-(1-k%TOTALPATH)*DH/EL%P%beta0
    ELSE
       EL%LX(1)=EL%LX(1)+k%TOTALPATH*DH
    ENDIF


    DO I=1,3
       DO J=1,3
          CALL KILL(HX(I,J));CALL KILL(HY(I,J))
       ENDDO
    ENDDO
    DO I=1,6
       CALL KILL(V(I));CALL KILL(W(I))
       DO J=1,6;CALL KILL(HL(I,J))
       ENDDO
    ENDDO
    CALL KILL(DH);CALL KILL(X5);CALL KILL(X6);


  END SUBROUTINE GETMATD

  SUBROUTINE EXPR(H,MATOUT)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: H(3,3),MATOUT(2,3)
    real(dp) AD(3,3),TEMP(3,3)
    real(dp) NORM,NORM0,NORMAT,NORMAT0
    logical(lp) FIRST
    INTEGER I,J,K,N

    DO I=1,2
       DO J=1,3
          MATOUT(I,J)=0.0_dp
       ENDDO
    ENDDO
    DO I=1,3
       DO J=1,3
          AD(I,J)=0.0_dp
          TEMP(I,J)=0.0_dp
       ENDDO
    ENDDO
    MATOUT(1,1)=1.0_dp
    MATOUT(2,2)=1.0_dp
    AD(1,1)=1.0_dp
    AD(2,2)=1.0_dp
    AD(3,3)=1.0_dp
    FIRST=.TRUE.
    NORM=1e6_dp
    NORMAT=2e5_dp
    DO N=1,NMAXI
       !  COMPUTING H**N/N!
       DO I=1,3
          DO J=1,3
             DO K=1,3
                TEMP(I,K)=H(I,J)*AD(J,K)+TEMP(I,K)
             ENDDO
          ENDDO
       ENDDO
       NORM0=NORM
       NORMAT0=NORMAT
       !  ADDING TO MATOUT
       NORM=0.0_dp
       NORMAT=0.0_dp
       DO I=1,3   !2
          DO J=1,3
             AD(I,J)=TEMP(I,J)/N
             IF(I/=3) MATOUT(I,J)=MATOUT(I,J)+AD(I,J)
             IF(I/=3) NORMAT=NORMAT+ABS(MATOUT(I,J))
             TEMP(I,J)=0.0_dp
          ENDDO
       ENDDO
       NORM=ABS(NORMAT-NORMAT0)


       IF(FIRST) THEN
          IF(NORM<EPS_DEF_KIND) THEN
             FIRST=.FALSE.
          ENDIF
       ELSE
          IF(NORM>=NORM0) GOTO 100
       ENDIF


    ENDDO

    w_p=0
    w_p%nc=1
    w_p%fc='(1(1X,A72))'
    write(w_p%c(1),'(A31,1X,I4,1X,A11)') " EXPSOLR FAILED TO CONVERGE IN ",NMAXI," ITERATIONS"
    ! call !write_e(0)

100 CONTINUE

  END SUBROUTINE EXPR

  SUBROUTINE EXPD(H,MATOUT)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: H(3,3),MATOUT(2,3)
    TYPE(REAL_8) AD(3,3),TEMP(3,3)
    real(dp) NORM,NORM0,NORMAT,NORMAT0
    logical(lp) FIRST
    INTEGER I,J,K,N

    DO I=1,2
       DO J=1,3
          MATOUT(I,J)=0.0_dp
       ENDDO
    ENDDO
    DO I=1,3
       DO J=1,3
          CALL ALLOC(AD(I,J))
          CALL ALLOC(TEMP(I,J))
       ENDDO
    ENDDO
    MATOUT(1,1)=1.0_dp
    MATOUT(2,2)=1.0_dp
    AD(1,1)=1.0_dp
    AD(2,2)=1.0_dp
    AD(3,3)=1.0_dp
    FIRST=.TRUE.
    NORM=1e6_dp
    NORMAT=2e5_dp
    DO N=1,NMAXI
       !  COMPUTING H**N/N!
       DO I=1,3
          DO J=1,3
             DO K=1,3
                TEMP(I,K)=H(I,J)*AD(J,K)+TEMP(I,K)
             ENDDO
          ENDDO
       ENDDO
       NORM0=NORM
       NORMAT0=NORMAT
       !  ADDING TO MATOUT
       NORM=0.0_dp
       NORMAT=0.0_dp
       DO I=1,3   !2
          DO J=1,3
             AD(I,J)=TEMP(I,J)/N
             IF(I/=3) MATOUT(I,J)=MATOUT(I,J)+AD(I,J)
             IF(I/=3) NORMAT=NORMAT+ABS(MATOUT(I,J))
             TEMP(I,J)=0.0_dp
          ENDDO
       ENDDO
       NORM=ABS(NORMAT-NORMAT0)


       IF(FIRST) THEN
          IF(NORM<EPS_DEF_KIND) THEN
             FIRST=.FALSE.
          ENDIF
       ELSE
          IF(NORM>=NORM0) GOTO 100
       ENDIF


    ENDDO

    w_p=0
    w_p%nc=1
    w_p%fc='(1(1X,A72))'
    write(w_p%c(1),'(A31,1X,I4,1X,A11)') " EXPSOLR FAILED TO CONVERGE IN ",NMAXI," ITERATIONS"
    ! call !write_e(0)

100 CONTINUE

    DO I=1,3
       DO J=1,3
          CALL KILL(AD(I,J))
          CALL KILL(TEMP(I,J))
       ENDDO
    ENDDO


  END SUBROUTINE EXPD


  SUBROUTINE EXP6R(H,V,MATOUT)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: H(6,6),V(6),MATOUT(6)
    real(dp) AD(6),TEMP(6)
    real(dp) NORM,NORM0,NORMAT,NORMAT0
    logical(lp) FIRST
    INTEGER I,J,N

    DO I=1,6
       MATOUT(I)=V(I)
       AD(I)=V(I)
       TEMP(I)=0.0_dp
    ENDDO
    FIRST=.TRUE.
    NORM=1e6_dp
    NORMAT=2e5_dp
    DO N=1,NMAXI
       !  COMPUTING H**N/N!
       DO I=1,6
          DO J=1,6
             TEMP(I)=H(I,J)*AD(J)+TEMP(I)
          ENDDO
       ENDDO
       NORM0=NORM
       NORMAT0=NORMAT
       !  ADDING TO MATOUT
       NORM=0.0_dp
       NORMAT=0.0_dp
       DO I=1,6   !2
          AD(I)=TEMP(I)/(N+1)
          MATOUT(I)=MATOUT(I)+AD(I)
          NORMAT=NORMAT+ABS(MATOUT(I))
          TEMP(I)=0.0_dp
       ENDDO
       NORM=ABS(NORMAT-NORMAT0)


       IF(FIRST) THEN
          IF(NORM<EPS_DEF_KIND) THEN
             FIRST=.FALSE.
          ENDIF
       ELSE
          IF(NORM>=NORM0) GOTO 100
       ENDIF


    ENDDO

    w_p=0
    w_p%nc=1
    w_p%fc='(1(1X,A72))'
    write(w_p%c(1),'(A31,1X,I4,1X,A11)') " EXPSOLR FAILED TO CONVERGE IN ",NMAXI," ITERATIONS"
    ! call !write_e(0)

100 CONTINUE

  END SUBROUTINE EXP6R


  SUBROUTINE EXP6D(H,V,MATOUT)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: H(6,6),V(6),MATOUT(6)
    TYPE(REAL_8) AD(6),TEMP(6)
    real(dp) NORM,NORM0,NORMAT,NORMAT0
    logical(lp) FIRST
    INTEGER I,J,N

    CALL ALLOC(AD,6)
    CALL ALLOC(TEMP,6)

    DO I=1,6
       MATOUT(I)=V(I)
       AD(I)=V(I)
       TEMP(I)=0.0_dp
    ENDDO
    FIRST=.TRUE.
    NORM=1e6_dp
    NORMAT=2e5_dp
    DO N=1,NMAXI
       !  COMPUTING H**N/N!
       DO I=1,6
          DO J=1,6
             TEMP(I)=H(I,J)*AD(J)+TEMP(I)
          ENDDO
       ENDDO
       NORM0=NORM
       NORMAT0=NORMAT
       !  ADDING TO MATOUT
       NORM=0.0_dp
       NORMAT=0.0_dp
       DO I=1,6   !2
          AD(I)=TEMP(I)/(N+1)
          MATOUT(I)=MATOUT(I)+AD(I)
          NORMAT=NORMAT+ABS(MATOUT(I))
          TEMP(I)=0.0_dp
       ENDDO
       NORM=ABS(NORMAT-NORMAT0)


       IF(FIRST) THEN
          IF(NORM<EPS_DEF_KIND) THEN
             FIRST=.FALSE.
          ENDIF
       ELSE
          IF(NORM>=NORM0) GOTO 100
       ENDIF


    ENDDO

    w_p=0
    w_p%nc=1
    w_p%fc='(1(1X,A72))'
    write(w_p%c(1),'(A31,1X,I4,1X,A11)') " EXPSOLR FAILED TO CONVERGE IN ",NMAXI," ITERATIONS"
    ! call !write_e(0)

100 CONTINUE


    CALL KILL(AD,6)
    CALL KILL(TEMP,6)

  END SUBROUTINE EXP6D
  !  ZEROING AND COPY ROUTINES

  SUBROUTINE INTER_KTK(EL,X,k)
    IMPLICIT NONE
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(KTK),INTENT(INOUT):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    real(dp) DK,DK2,DK6,DK4,DK5



    SELECT CASE(EL%P%METHOD)
    CASE(2)
       DK2=EL%L/EL%P%NST
       DK=DK2/2.0_dp

       IF(OLD_IMPLEMENTATION_OF_SIXTRACK) THEN

          CALL GETMAT(EL,X,k)
          CALL KICKKTK(EL,DK,X,k)  ! NEW
          CALL KICKPATH(EL,DK,X,k)
          CALL PUSHKTK(EL,X)

          CALL KICKPATH(EL,DK,X,k)
          CALL KICKKTK(EL,DK,X,k)  ! NEW
       ELSE  ! OLD_IMPLEMENTATION_OF_SIXTRACK
          CALL GETMAT(EL,X,k)
          CALL PUSHKTK(EL,X)
          CALL KICKPATH(EL,DK,X,k)
          CALL KICKKTK(EL,DK2,X,k)  ! NEW
          CALL KICKPATH(EL,DK,X,k)
          CALL PUSHKTK(EL,X)

       ENDIF ! OLD_IMPLEMENTATION_OF_SIXTRACK

    CASE(4)
       DK2=EL%L/EL%P%NST/3.0_dp
       DK6=2.0_dp*DK2
       DK=DK2/2.0_dp
       CALL GETMAT(EL,X,k)
       CALL KICKKTK(EL,DK,X,k)    ! NEW
       CALL KICKPATH(EL,DK,X,k)
       CALL PUSHKTK(EL,X)
       CALL KICKPATH(EL,DK2,X,k)
       CALL KICKKTK(EL,DK6,X,k)
       CALL KICKPATH(EL,DK2,X,k)
       CALL PUSHKTK(EL,X)
       CALL KICKPATH(EL,DK,X,k)
       CALL KICKKTK(EL,DK,X,k) ! NEW
    CASE(6)
       DK2=14.0_dp*EL%L/EL%P%NST/90.0_dp
       DK4=32.0_dp*EL%L/EL%P%NST/90.0_dp
       DK6=12.0_dp*EL%L/EL%P%NST/90.0_dp
       DK5=DK6/2.0_dp
       DK=DK2/2.0_dp


       CALL GETMAT(EL,X,k)
       CALL KICKKTK(EL,DK,X,k)   ! NEW
       CALL KICKPATH(EL,DK,X,k)

       CALL PUSHKTK(EL,X)

       CALL KICKKTK(EL,DK4,X,k)
       CALL KICKPATH(EL,DK4,X,k)

       CALL PUSHKTK(EL,X)

       CALL KICKPATH(EL,DK5,X,k)
       CALL KICKKTK(EL,DK6,X,k)   ! SYMMETRY POINT
       CALL KICKPATH(EL,DK5,X,k)

       CALL PUSHKTK(EL,X)

       CALL KICKPATH(EL,DK4,X,k)
       CALL KICKKTK(EL,DK4,X,k)

       CALL PUSHKTK(EL,X)
       CALL KICKPATH(EL,DK,X,k)
       CALL KICKKTK(EL,DK,X,k)   ! NEW

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

  END SUBROUTINE INTER_KTK

  SUBROUTINE INTEP_KTK(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(KTKP),INTENT(INOUT):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    TYPE(REAL_8) DK,DK2,DK6,DK4,DK5


    CALL ALLOC(EL)   ! etienne in daresbury

    SELECT CASE(EL%P%METHOD)
    CASE(2)
       CALL ALLOC(DK2,DK)
       DK2=EL%L/EL%P%NST
       DK=DK2/2.0_dp

       IF(OLD_IMPLEMENTATION_OF_SIXTRACK) THEN



          CALL GETMAT(EL,X,k)
          CALL KICKKTK(EL,DK,X,k)  ! NEW
          CALL KICKPATH(EL,DK,X,k)
          CALL PUSHKTK(EL,X)

          CALL KICKPATH(EL,DK,X,k)
          CALL KICKKTK(EL,DK,X,k)  ! NEW
       ELSE  ! OLD_IMPLEMENTATION_OF_SIXTRACK
          CALL GETMAT(EL,X,k)
          CALL PUSHKTK(EL,X)
          CALL KICKPATH(EL,DK,X,k)
          CALL KICKKTK(EL,DK2,X,k)  ! NEW
          CALL KICKPATH(EL,DK,X,k)
          CALL PUSHKTK(EL,X)

       ENDIF ! OLD_IMPLEMENTATION_OF_SIXTRACK
       CALL KILL(DK2,DK)

    CASE(4)
       CALL ALLOC(DK,DK2,DK6)
       DK2=EL%L/EL%P%NST/3.0_dp
       DK6=2.0_dp*DK2
       DK=DK2/2.0_dp
       CALL GETMAT(EL,X,k)
       CALL KICKKTK(EL,DK,X,k)    ! NEW
       CALL KICKPATH(EL,DK,X,k)
       CALL PUSHKTK(EL,X)
       CALL KICKPATH(EL,DK2,X,k)
       CALL KICKKTK(EL,DK6,X,k)
       CALL KICKPATH(EL,DK2,X,k)
       CALL PUSHKTK(EL,X)
       CALL KICKPATH(EL,DK,X,k)
       CALL KICKKTK(EL,DK,X,k) ! NEW
       CALL KILL(DK,DK2,DK6)
    CASE(6)
       CALL ALLOC(DK,DK2,DK4,DK5,DK6)
       DK2=14.0_dp*EL%L/EL%P%NST/90.0_dp
       DK4=32.0_dp*EL%L/EL%P%NST/90.0_dp
       DK6=12.0_dp*EL%L/EL%P%NST/90.0_dp
       DK5=DK6/2.0_dp
       DK=DK2/2.0_dp


       CALL GETMAT(EL,X,k)
       CALL KICKKTK(EL,DK,X,k)   ! NEW
       CALL KICKPATH(EL,DK,X,k)

       CALL PUSHKTK(EL,X)

       CALL KICKKTK(EL,DK4,X,k)
       CALL KICKPATH(EL,DK4,X,k)

       CALL PUSHKTK(EL,X)

       CALL KICKPATH(EL,DK5,X,k)
       CALL KICKKTK(EL,DK6,X,k)   ! SYMMETRY POINT
       CALL KICKPATH(EL,DK5,X,k)

       CALL PUSHKTK(EL,X)

       CALL KICKPATH(EL,DK4,X,k)
       CALL KICKKTK(EL,DK4,X,k)

       CALL PUSHKTK(EL,X)
       CALL KICKPATH(EL,DK,X,k)
       CALL KICKKTK(EL,DK,X,k)   ! NEW
       CALL KILL(DK,DK2,DK4,DK5,DK6)

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT
    CALL kill(EL)

  END SUBROUTINE INTEP_KTK

  SUBROUTINE INTKTKR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(KTK),INTENT(INOUT):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(PRESENT(MID)) CALL XMID(MID,X,0)
    IF(.NOT.PRESENT(MID))CALL GETMAT(EL,X,k)

    DO I=1,EL%P%NST
       IF(.NOT.PRESENT(MID)) CALL TRACK_SLICE(EL,X,k)
       IF(PRESENT(MID)) CALL XMID(MID,X,I)
    ENDDO


  END SUBROUTINE INTKTKR

  SUBROUTINE INTKTKD(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(KTKP),INTENT(INOUT):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    !    CALL ALLOC(EL)
    !    CALL GETMAT(EL,X,k)


    DO I=1,EL%P%NST
       CALL TRACK_SLICE(EL,X,k)
    ENDDO


    !    CALL KILL(EL)

  END SUBROUTINE INTKTKD


  SUBROUTINE PUSHKTKR(EL,X)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(KTK),INTENT(IN):: EL
    real(dp) T(6)

    T(1)=EL%MATX(1,1)*X(1)+EL%MATX(1,2)*X(2)+EL%MATX(1,3)*X(5)
    T(2)=EL%MATX(2,1)*X(1)+EL%MATX(2,2)*X(2)+EL%MATX(2,3)*X(5)
    T(3)=EL%MATY(1,1)*X(3)+EL%MATY(1,2)*X(4)
    T(4)=EL%MATY(2,1)*X(3)+EL%MATY(2,2)*X(4)
    T(6)=X(6)+EL%LX(1)+EL%LX(2)*X(1)+EL%LX(3)*X(2)
    T(6)=T(6)+EL%LX(4)*X(1)**2+EL%LX(5)*X(1)*X(2)+EL%LX(6)*X(2)**2
    T(6)=T(6)+EL%LY(1)*X(3)**2+EL%LY(2)*X(3)*X(4)+EL%LY(3)*X(4)**2

    X(1)=T(1);X(2)=T(2);X(3)=T(3);X(4)=T(4);X(6)=T(6);

  END SUBROUTINE PUSHKTKR

  SUBROUTINE PUSHKTKD(EL,X)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(KTKP),INTENT(IN):: EL
    TYPE(REAL_8) T(6)

    CALL ALLOC(T)
    T(1)=EL%MATX(1,1)*X(1)+EL%MATX(1,2)*X(2)+EL%MATX(1,3)*X(5)
    T(2)=EL%MATX(2,1)*X(1)+EL%MATX(2,2)*X(2)+EL%MATX(2,3)*X(5)
    T(3)=EL%MATY(1,1)*X(3)+EL%MATY(1,2)*X(4)
    T(4)=EL%MATY(2,1)*X(3)+EL%MATY(2,2)*X(4)
    T(6)=X(6)+EL%LX(1)+EL%LX(2)*X(1)+EL%LX(3)*X(2)
    T(6)=T(6)+EL%LX(4)*X(1)**2+EL%LX(5)*X(1)*X(2)+EL%LX(6)*X(2)**2
    T(6)=T(6)+EL%LY(1)*X(3)**2+EL%LY(2)*X(3)*X(4)+EL%LY(3)*X(4)**2

    X(1)=T(1);X(2)=T(2);X(3)=T(3);X(4)=T(4);X(6)=T(6);

    CALL KILL(T)

  END SUBROUTINE PUSHKTKD


  SUBROUTINE KICKKTKR(EL,YL,X,k)   !ETIENNE
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(KTK),INTENT(IN):: EL
    real(dp),INTENT(IN):: YL
    real(dp) X1,X3,X5,BBYTW,BBXTW,BBYTWT
    INTEGER J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    DIR=EL%P%DIR*EL%P%CHARGE

    X1=X(1)
    X3=X(3)

    if(k%TIME) then
       X5=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)-1.0_dp
    else
       X5=X(5)
    endif


    IF(EL%P%NMUL>=1) THEN
       BBYTW=EL%BN(EL%P%NMUL)
       BBXTW=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,1,-1
          BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
          BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
          BBYTW=BBYTWT
       ENDDO
    ELSE
       BBYTW=0.0_dp
       BBXTW=0.0_dp
    ENDIF


    X(2)=X(2)-YL*DIR*(BBYTW-DIR*EL%P%B0-EL%BN(2)*X(1))
    X(4)=X(4)+YL*DIR*(BBXTW-EL%BN(2)*X(3))

    !outvalishev    if(valishev.and.ABS(el%VS)>eps)   then  !valishev
    !outvalishev     call elliptical_b(el%VA,el%VS,x,BBXTW,BBYTW) !valishev
    !outvalishev       X(2)=X(2)-YL*DIR*BBYTW !valishev
    !outvalishev       X(4)=X(4)+YL* DIR*BBXTW !valishev
    !outvalishev    endif !valishev

  END SUBROUTINE KICKKTKR



  SUBROUTINE KICKKTKP(EL,YL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(KTKP),INTENT(IN):: EL
    TYPE(REAL_8),INTENT(IN):: YL
    TYPE(REAL_8) X1,X3,X5,BBYTW,BBXTW,BBYTWT
    INTEGER J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    DIR=EL%P%DIR*EL%P%CHARGE

    CALL ALLOC(X1)
    CALL ALLOC(X3)
    CALL ALLOC(X5)
    CALL ALLOC(BBYTW)
    CALL ALLOC(BBXTW)
    CALL ALLOC(BBYTWT)


    X1=X(1)
    X3=X(3)
    if(k%TIME) then
       X5=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)-1.0_dp
    else
       X5=X(5)
    endif


    IF(EL%P%NMUL>=1) THEN
       BBYTW=EL%BN(EL%P%NMUL)
       BBXTW=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,1,-1
          BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
          BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
          BBYTW=BBYTWT
       ENDDO
    ELSE
       BBYTW=0.0_dp
       BBXTW=0.0_dp
    ENDIF


    X(2)=X(2)-YL*DIR*(BBYTW-DIR*EL%P%B0-EL%BN(2)*X(1))
    X(4)=X(4)+YL*DIR*(BBXTW-EL%BN(2)*X(3))

    !outvalishev    if(valishev.and.ABS(el%VS)>eps)   then  !valishev
    !outvalishev     call elliptical_b(el%VA,el%VS,x,BBXTW,BBYTW) !valishev
    !outvalishev       X(2)=X(2)-YL*DIR*BBYTW !valishev
    !outvalishev       X(4)=X(4)+YL* DIR*BBXTW !valishev
    !outvalishev    endif !valishev


    CALL KILL(X1)
    CALL KILL(X3)
    CALL KILL(X5)
    CALL KILL(BBYTW)
    CALL KILL(BBXTW)
    CALL KILL(BBYTWT)

  END SUBROUTINE KICKKTKP

  SUBROUTINE SYMPINTKTKR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(KTK),INTENT(INOUT):: EL
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    IF(.NOT.PRESENT(MID))CALL TRACK_FRINGE(EL6=EL,X=X,k=k,J=1)
    CALL INTKTK(EL,X,k,MID)
    IF(.NOT.PRESENT(MID))CALL TRACK_FRINGE(EL6=EL,X=X,k=k,J=2)

  END SUBROUTINE SYMPINTKTKR

  SUBROUTINE SYMPINTKTKD(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(KTKP),INTENT(INOUT):: EL
    ! TYPE(WORM_8),OPTIONAL,INTENT(INOUT):: MID
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL TRACK_FRINGE(EL6=EL,X=X,k=k,J=1)
    CALL INTKTK(EL,X,k)
    CALL TRACK_FRINGE(EL6=EL,X=X,k=k,J=2)

  END SUBROUTINE SYMPINTKTKD


!!!! *************************************************************** !!!!
!!!! *                 End of the slow thick element               * !!!!
!!!! *************************************************************** !!!!


!!!! *************************************************************** !!!!
!!!! *           Beginning of the fast thick element               * !!!!
!!!! *************************************************************** !!!!
  SUBROUTINE GETMAT7R(EL)
    IMPLICIT NONE
    TYPE(TKTF),INTENT(INOUT):: EL
    real(dp) HX(4,4),HY(4,4)
    real(dp) DH
    INTEGER DIR
!!!!  SPEED STUFF !!!
    real(dp) OMEGA, OMEGA2,C,S
    INTEGER S_OMEGA

    IF(MOD(EL%P%METHOD,2)==1) THEN
       DH=(EL%L/EL%P%NST)  ! method=1,3,5
    ELSEIF(EL%P%METHOD/=6) THEN
       DH=(EL%L/EL%P%NST)/EL%P%METHOD   ! method=1,2
       IF(EL%P%METHOD==4) DH=DH*2.0_dp
    ELSE
       DH=EL%L/EL%P%NST/4.0_dp
    ENDIF

    DIR=1
    IF(SPEED) THEN

       S_OMEGA=-1
       OMEGA2=DIR*(EL%BN(2)+EL%P%B0*EL%BN(1))

       IF(OMEGA2<0.0_dp) THEN
          OMEGA2=-OMEGA2
          S_OMEGA=1
       ENDIF
       if(OMEGA2.eq.0.0_dp) then   ! for Lahey bug in quadruple precision
          OMEGA=0.0_dp             ! not done yet on TPSA part
       else
          OMEGA=SQRT(OMEGA2)
       endif

       IF(OMEGA>0.0_dp) THEN
          IF(S_OMEGA==1) THEN
             C=COSH(OMEGA*DH)
             S=SINH(OMEGA*DH)
          ELSE
             C=COS(OMEGA*DH)
             S=SIN(OMEGA*DH)
          ENDIF
          EL%MATX(1,1)=C;
          EL%MATX(1,2)=S/OMEGA;
          EL%MATX(1,3)= EL%P%B0*(C-1.0_dp)/OMEGA2*S_OMEGA;

          EL%MATX(2,1)=S_OMEGA*OMEGA*S; EL%MATX(2,2)=C;
          EL%MATX(2,3)= EL%P%B0*EL%MATX(1,2);
          EL%LX(1)=EL%P%B0*EL%MATX(1,2);   EL%LX(2)=EL%MATX(1,3);
          EL%LX(3)=-EL%P%B0**2*S_OMEGA*(DH-EL%MATX(1,2))/OMEGA2;
       ELSE
          EL%MATX(1,1)=1.0_dp;EL%MATX(1,2)=DH;
          EL%MATX(2,1)=0.0_dp
          EL%MATX(2,2)=1.0_dp
          EL%MATX(2,3)= EL%P%B0*DH;
          EL%MATX(1,3)= EL%MATX(2,3)*DH/2.0_dp;
          EL%LX(1)=EL%MATX(2,3);EL%LX(2)=EL%MATX(1,3);
          EL%LX(3)=EL%MATX(1,3)*EL%P%B0*DH/3.0_dp
       ENDIF

       S_OMEGA=-1
       OMEGA2=-DIR*EL%BN(2)

       IF(OMEGA2<0.0_dp) THEN
          OMEGA2=-OMEGA2
          S_OMEGA=1
       ENDIF
       OMEGA=SQRT(OMEGA2)


       IF(OMEGA>0.0_dp) THEN
          IF(S_OMEGA==1) THEN
             C=COSH(OMEGA*DH)
             S=SINH(OMEGA*DH)
          ELSE
             C=COS(OMEGA*DH)
             S=SIN(OMEGA*DH)
          ENDIF
          EL%MATY(1,1)=C;
          EL%MATY(1,2)=S/OMEGA;
          EL%MATY(1,3)=0.0_dp;
          EL%MATY(2,1)=S_OMEGA*OMEGA*S; EL%MATY(2,2)=C;
          EL%MATY(2,3)=0.0_dp;
       ELSE
          EL%MATY(1,3)=0.0_dp;
          EL%MATY(2,3)=0.0_dp;
          EL%MATY(1,1)=1.0_dp;EL%MATY(1,2)=DH;
          EL%MATY(2,2)=1.0_dp;EL%MATY(2,1)=0.0_dp;
       ENDIF





    ELSE     !  SPEED FALSE OR KNOB TRUE


       HX(1,1)=0.0_dp;HX(1,2)=DH;HX(1,3)=0.0_dp;HX(1,4)=0.0_dp;
       HX(2,1)=-DH*DIR*(EL%BN(2)+EL%P%B0*EL%BN(1));HX(2,2)=0.0_dp;HX(2,3)=DH*EL%P%B0;HX(2,4)=0.0_dp;
       HX(3,1)=0.0_dp;HX(3,2)=0.0_dp;HX(3,3)=0.0_dp;HX(3,4)=0.0_dp;
       HX(4,1)=DH*EL%P%B0;HX(4,2)=0.0_dp;HX(4,3)=0.0_dp;HX(4,4)=0.0_dp;

       HY(1,1)=0.0_dp;HY(1,2)=HX(1,2);HY(1,3)=0.0_dp;HY(1,4)=0.0_dp;
       HY(2,1)=DH*DIR*EL%BN(2);HY(2,2)=0.0_dp;HY(2,3)=0.0_dp;HY(2,4)=0.0_dp;
       HY(3,1)=0.0_dp;HY(3,2)=0.0_dp;HY(3,3)=0.0_dp;HY(3,4)=0.0_dp;
       HY(4,1)=0.0_dp;HY(4,2)=0.0_dp;HY(4,3)=0.0_dp;HY(4,4)=0.0_dp;

       ! BUG FOUND BY SCHMIDT (SUBTLE ONE; AFFECTS PTC LOGIC; YUCK!)

       !    IF(k%TIME) THEN
       !       HX(2,3)=HX(2,3)/el%P%beta0
       !       HX(4,1)=HX(4,1)/el%P%beta0
       !    ENDIF

       CALL EXPCOSY7(HY,EL%MATY,EL%LX)
       CALL EXPCOSY7(HX,EL%MATX,EL%LX)







    ENDIF


    DIR=-1
    IF(SPEED) THEN

       S_OMEGA=-1
       OMEGA2=DIR*(EL%BN(2)+EL%P%B0*EL%BN(1))

       IF(OMEGA2<0.0_dp) THEN
          OMEGA2=-OMEGA2
          S_OMEGA=1
       ENDIF

       if(OMEGA2.eq.0.0_dp) then    ! for Lahey bug in quadruple precision
          OMEGA=0.0_dp
       else
          OMEGA=SQRT(OMEGA2)
       endif

       IF(OMEGA>0.0_dp) THEN
          IF(S_OMEGA==1) THEN
             C=COSH(OMEGA*DH)
             S=SINH(OMEGA*DH)
          ELSE
             C=COS(OMEGA*DH)
             S=SIN(OMEGA*DH)
          ENDIF
          EL%RMATX(1,1)=C;
          EL%RMATX(1,2)=S/OMEGA;
          EL%RMATX(1,3)= EL%P%B0*(C-1.0_dp)/OMEGA2*S_OMEGA;
          EL%RMATX(2,1)=S_OMEGA*OMEGA*S; EL%RMATX(2,2)=C;
          EL%RMATX(2,3)= EL%P%B0*EL%RMATX(1,2);
          EL%RLX(1)=EL%P%B0*EL%RMATX(1,2);   EL%RLX(2)=EL%RMATX(1,3);
          EL%RLX(3)=-EL%P%B0**2*S_OMEGA*(DH-EL%RMATX(1,2))/OMEGA2;
       ELSE
          EL%RMATX(1,1)=1.0_dp;EL%RMATX(1,2)=DH;
          EL%RMATX(2,1)=0.0_dp
          EL%RMATX(2,2)=1.0_dp
          EL%RMATX(2,3)= EL%P%B0*DH;
          EL%RMATX(1,3)= EL%RMATX(2,3)*DH/2.0_dp;
          EL%RLX(1)=EL%RMATX(2,3);EL%RLX(2)=EL%RMATX(1,3);
          EL%RLX(3)=EL%RMATX(1,3)*EL%P%B0*DH/3.0_dp
       ENDIF

       S_OMEGA=-1
       OMEGA2=-DIR*EL%BN(2)

       IF(OMEGA2<0.0_dp) THEN
          OMEGA2=-OMEGA2
          S_OMEGA=1
       ENDIF
       OMEGA=SQRT(OMEGA2)


       IF(OMEGA>0.0_dp) THEN
          IF(S_OMEGA==1) THEN
             C=COSH(OMEGA*DH)
             S=SINH(OMEGA*DH)
          ELSE
             C=COS(OMEGA*DH)
             S=SIN(OMEGA*DH)
          ENDIF
          EL%RMATY(1,1)=C;
          EL%RMATY(1,2)=S/OMEGA;
          EL%RMATY(1,3)=0.0_dp;
          EL%RMATY(2,1)=S_OMEGA*OMEGA*S; EL%RMATY(2,2)=C;
          EL%RMATY(2,3)=0.0_dp;
       ELSE
          EL%RMATY(1,3)=0.0_dp;
          EL%RMATY(2,3)=0.0_dp;
          EL%RMATY(1,1)=1.0_dp;EL%RMATY(1,2)=DH;
          EL%RMATY(2,2)=1.0_dp;EL%RMATY(2,1)=0.0_dp;
       ENDIF





    ELSE     !  SPEED FALSE OR KNOB TRUE


       HX(1,1)=0.0_dp;HX(1,2)=DH;HX(1,3)=0.0_dp;HX(1,4)=0.0_dp;
       HX(2,1)=-DH*DIR*(EL%BN(2)+EL%P%B0*EL%BN(1));HX(2,2)=0.0_dp;HX(2,3)=DH*EL%P%B0;HX(2,4)=0.0_dp;
       HX(3,1)=0.0_dp;HX(3,2)=0.0_dp;HX(3,3)=0.0_dp;HX(3,4)=0.0_dp;
       HX(4,1)=DH*EL%P%B0;HX(4,2)=0.0_dp;HX(4,3)=0.0_dp;HX(4,4)=0.0_dp;

       HY(1,1)=0.0_dp;HY(1,2)=HX(1,2);HY(1,3)=0.0_dp;HY(1,4)=0.0_dp;
       HY(2,1)=DH*DIR*EL%BN(2);HY(2,2)=0.0_dp;HY(2,3)=0.0_dp;HY(2,4)=0.0_dp;
       HY(3,1)=0.0_dp;HY(3,2)=0.0_dp;HY(3,3)=0.0_dp;HY(3,4)=0.0_dp;
       HY(4,1)=0.0_dp;HY(4,2)=0.0_dp;HY(4,3)=0.0_dp;HY(4,4)=0.0_dp;

       ! BUG FOUND BY SCHMIDT (SUBTLE ONE; AFFECTS PTC LOGIC; YUCK!)

       !    IF(k%TIME) THEN
       !       HX(2,3)=HX(2,3)/el%P%beta0
       !       HX(4,1)=HX(4,1)/el%P%beta0
       !    ENDIF

       CALL EXPCOSY7(HY,EL%RMATY,EL%RLX)
       CALL EXPCOSY7(HX,EL%RMATX,EL%RLX)







    ENDIF





  END SUBROUTINE GETMAT7R

  SUBROUTINE GETMAT7D(EL)
    IMPLICIT NONE
    TYPE(TKTFP),INTENT(INOUT):: EL
    TYPE(REAL_8) HX(4,4),HY(4,4)
    TYPE(REAL_8) DH
    INTEGER I,J,DIR
!!!!  SPEED STUFF !!!
    real(dp) OMEGA, OMEGA2,C,S
    INTEGER S_OMEGA

    DO I=1,4
       DO J=1,4
          CALL ALLOC(HX(I,J))
          CALL ALLOC(HY(I,J))
       ENDDO
    ENDDO
    CALL ALLOC(DH)


    IF(MOD(EL%P%METHOD,2)==1) THEN
       DH=(EL%L/EL%P%NST)  ! method=1,2
    ELSEIF(EL%P%METHOD/=6) THEN
       DH=(EL%L/EL%P%NST)/EL%P%METHOD   ! method=1,2
       IF(EL%P%METHOD==4) DH=DH*2.0_dp
    ELSE
       DH=EL%L/EL%P%NST/4.0_dp
    ENDIF

    DIR=1
    IF(SPEED.AND.(.NOT.KNOB)) THEN

       S_OMEGA=-1
       OMEGA2=DIR*(EL%BN(2)+EL%P%B0*EL%BN(1))

       IF(OMEGA2<0.0_dp) THEN
          OMEGA2=-OMEGA2
          S_OMEGA=1
       ENDIF
       OMEGA=SQRT(OMEGA2)


       IF(OMEGA>0.0_dp) THEN
          IF(S_OMEGA==1) THEN
             C=COSH(OMEGA*DH)
             S=SINH(OMEGA*DH)
          ELSE
             C=COS(OMEGA*DH)
             S=SIN(OMEGA*DH)
          ENDIF
          EL%MATX(1,1)=C;
          EL%MATX(1,2)=S/OMEGA;
          EL%MATX(1,3)= EL%P%B0*(C-1.0_dp)/OMEGA2*S_OMEGA;
          EL%MATX(2,1)=S_OMEGA*OMEGA*S; EL%MATX(2,2)=C;
          EL%MATX(2,3)= EL%P%B0*EL%MATX(1,2);
          EL%LX(1)=EL%P%B0*EL%MATX(1,2);   EL%LX(2)=EL%MATX(1,3);
          EL%LX(3)=-EL%P%B0**2*S_OMEGA*(DH-EL%MATX(1,2))/OMEGA2;
       ELSE
          EL%MATX(1,1)=1.0_dp;EL%MATX(1,2)=DH;
          EL%MATX(2,1)=0.0_dp
          EL%MATX(2,2)=1.0_dp
          EL%MATX(2,3)= EL%P%B0*DH;
          EL%MATX(1,3)= EL%MATX(2,3)*DH/2.0_dp;
          EL%LX(1)=EL%MATX(2,3);EL%LX(2)=EL%MATX(1,3);
          EL%LX(3)=EL%MATX(1,3)*EL%P%B0*DH/3.0_dp
       ENDIF


       S_OMEGA=-1
       OMEGA2=-DIR*EL%BN(2)

       IF(OMEGA2<0.0_dp) THEN
          OMEGA2=-OMEGA2
          S_OMEGA=1
       ENDIF
       OMEGA=SQRT(OMEGA2)


       IF(OMEGA>0.0_dp) THEN
          IF(S_OMEGA==1) THEN
             C=COSH(OMEGA*DH)
             S=SINH(OMEGA*DH)
          ELSE
             C=COS(OMEGA*DH)
             S=SIN(OMEGA*DH)
          ENDIF
          EL%MATY(1,1)=C;
          EL%MATY(1,2)=S/OMEGA;
          EL%MATY(1,3)=0.0_dp;
          EL%MATY(2,1)=S_OMEGA*OMEGA*S; EL%MATY(2,2)=C;
          EL%MATY(2,3)=0.0_dp;
       ELSE
          EL%MATY(1,3)=0.0_dp;
          EL%MATY(2,3)=0.0_dp;
          EL%MATY(1,1)=1.0_dp;EL%MATY(1,2)=DH;
          EL%MATY(2,2)=1.0_dp;EL%MATY(2,1)=0.0_dp;
       ENDIF




    ELSE     !  SPEED FALSE OR KNOB TRUE


       HX(1,1)=0.0_dp;HX(1,2)=DH;HX(1,3)=0.0_dp;HX(1,4)=0.0_dp;
       HX(2,1)=-DH*DIR*(EL%BN(2)+EL%P%B0*EL%BN(1));HX(2,2)=0.0_dp;HX(2,3)=DH*EL%P%B0;HX(2,4)=0.0_dp;
       HX(3,1)=0.0_dp;HX(3,2)=0.0_dp;HX(3,3)=0.0_dp;HX(3,4)=0.0_dp;
       HX(4,1)=DH*EL%P%B0;HX(4,2)=0.0_dp;HX(4,3)=0.0_dp;HX(4,4)=0.0_dp;

       HY(1,1)=0.0_dp;HY(1,2)=HX(1,2);HY(1,3)=0.0_dp;HY(1,4)=0.0_dp;
       HY(2,1)=DH*DIR*EL%BN(2);HY(2,2)=0.0_dp;HY(2,3)=0.0_dp;HY(2,4)=0.0_dp;
       HY(3,1)=0.0_dp;HY(3,2)=0.0_dp;HY(3,3)=0.0_dp;HY(3,4)=0.0_dp;
       HY(4,1)=0.0_dp;HY(4,2)=0.0_dp;HY(4,3)=0.0_dp;HY(4,4)=0.0_dp;


       ! BUG FOUND BY SCHMIDT (SUBTLE ONE; AFFECTS PTC LOGIC; YUCK!)

       !    IF(k%TIME) THEN
       !       HX(2,3)=HX(2,3)/el%P%beta0
       !       HX(4,1)=HX(4,1)/el%P%beta0
       !    ENDIF


       CALL EXPCOSY7(HY,EL%MATY,EL%LX)
       CALL EXPCOSY7(HX,EL%MATX,EL%LX)


    ENDIF     !  SPEED FALSE OR KNOB TRUE

    DIR=-1
    IF(SPEED.AND.(.NOT.KNOB)) THEN

       S_OMEGA=-1
       OMEGA2=DIR*(EL%BN(2)+EL%P%B0*EL%BN(1))

       IF(OMEGA2<0.0_dp) THEN
          OMEGA2=-OMEGA2
          S_OMEGA=1
       ENDIF
       OMEGA=SQRT(OMEGA2)


       IF(OMEGA>0.0_dp) THEN
          IF(S_OMEGA==1) THEN
             C=COSH(OMEGA*DH)
             S=SINH(OMEGA*DH)
          ELSE
             C=COS(OMEGA*DH)
             S=SIN(OMEGA*DH)
          ENDIF
          EL%RMATX(1,1)=C;
          EL%RMATX(1,2)=S/OMEGA;
          EL%RMATX(1,3)= EL%P%B0*(C-1.0_dp)/OMEGA2*S_OMEGA;
          EL%RMATX(2,1)=S_OMEGA*OMEGA*S; EL%RMATX(2,2)=C;
          EL%RMATX(2,3)= EL%P%B0*EL%RMATX(1,2);
          EL%RLX(1)=EL%P%B0*EL%RMATX(1,2);   EL%RLX(2)=EL%RMATX(1,3);
          EL%RLX(3)=-EL%P%B0**2*S_OMEGA*(DH-EL%RMATX(1,2))/OMEGA2;
       ELSE
          EL%RMATX(1,1)=1.0_dp;EL%RMATX(1,2)=DH;
          EL%RMATX(2,1)=0.0_dp
          EL%RMATX(2,2)=1.0_dp
          EL%RMATX(2,3)= EL%P%B0*DH;
          EL%RMATX(1,3)= EL%RMATX(2,3)*DH/2.0_dp;
          EL%RLX(1)=EL%RMATX(2,3);EL%RLX(2)=EL%RMATX(1,3);
          EL%RLX(3)=EL%RMATX(1,3)*EL%P%B0*DH/3.0_dp
       ENDIF


       S_OMEGA=-1
       OMEGA2=-DIR*EL%BN(2)

       IF(OMEGA2<0.0_dp) THEN
          OMEGA2=-OMEGA2
          S_OMEGA=1
       ENDIF
       OMEGA=SQRT(OMEGA2)


       IF(OMEGA>0.0_dp) THEN
          IF(S_OMEGA==1) THEN
             C=COSH(OMEGA*DH)
             S=SINH(OMEGA*DH)
          ELSE
             C=COS(OMEGA*DH)
             S=SIN(OMEGA*DH)
          ENDIF
          EL%RMATY(1,1)=C;
          EL%RMATY(1,2)=S/OMEGA;
          EL%RMATY(1,3)=0.0_dp;
          EL%RMATY(2,1)=S_OMEGA*OMEGA*S; EL%RMATY(2,2)=C;
          EL%RMATY(2,3)=0.0_dp;
       ELSE
          EL%RMATY(1,3)=0.0_dp;
          EL%RMATY(2,3)=0.0_dp;
          EL%RMATY(1,1)=1.0_dp;EL%RMATY(1,2)=DH;
          EL%RMATY(2,2)=1.0_dp;EL%RMATY(2,1)=0.0_dp;
       ENDIF




    ELSE     !  SPEED FALSE OR KNOB TRUE


       HX(1,1)=0.0_dp;HX(1,2)=DH;HX(1,3)=0.0_dp;HX(1,4)=0.0_dp;
       HX(2,1)=-DH*DIR*(EL%BN(2)+EL%P%B0*EL%BN(1));HX(2,2)=0.0_dp;HX(2,3)=DH*EL%P%B0;HX(2,4)=0.0_dp;
       HX(3,1)=0.0_dp;HX(3,2)=0.0_dp;HX(3,3)=0.0_dp;HX(3,4)=0.0_dp;
       HX(4,1)=DH*EL%P%B0;HX(4,2)=0.0_dp;HX(4,3)=0.0_dp;HX(4,4)=0.0_dp;

       HY(1,1)=0.0_dp;HY(1,2)=HX(1,2);HY(1,3)=0.0_dp;HY(1,4)=0.0_dp;
       HY(2,1)=DH*DIR*EL%BN(2);HY(2,2)=0.0_dp;HY(2,3)=0.0_dp;HY(2,4)=0.0_dp;
       HY(3,1)=0.0_dp;HY(3,2)=0.0_dp;HY(3,3)=0.0_dp;HY(3,4)=0.0_dp;
       HY(4,1)=0.0_dp;HY(4,2)=0.0_dp;HY(4,3)=0.0_dp;HY(4,4)=0.0_dp;


       ! BUG FOUND BY SCHMIDT (SUBTLE ONE; AFFECTS PTC LOGIC; YUCK!)

       !    IF(k%TIME) THEN
       !       HX(2,3)=HX(2,3)/el%P%beta0
       !       HX(4,1)=HX(4,1)/el%P%beta0
       !    ENDIF

       CALL EXPCOSY7(HY,EL%RMATY,EL%RLX)
       CALL EXPCOSY7(HX,EL%RMATX,EL%RLX)



    ENDIF     !  SPEED FALSE OR KNOB TRUE


    DO I=1,4
       DO J=1,4
          CALL KILL(HX(I,J))
          CALL KILL(HY(I,J))
       ENDDO
    ENDDO
    CALL KILL(DH)





  END SUBROUTINE GETMAT7D

  SUBROUTINE PUSHTKT7R(EL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(TKTF),INTENT(IN):: EL
    real(dp) T(4)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    ! BUG FOUND BY SCHMIDT (SUBTLE ONE; AFFECTS PTC LOGIC; YUCK!)
    !    T(1)=EL%MATX(1,1)*X(1)+EL%MATX(1,2)*X(2)+EL%MATX(1,3)*X(5)
    !    T(2)=EL%MATX(2,1)*X(1)+EL%MATX(2,2)*X(2)+EL%MATX(2,3)*X(5)


    IF(EL%P%DIR*EL%P%CHARGE>0) THEN
       IF(k%TIME) THEN
          T(1)=EL%MATX(1,1)*X(1)+EL%MATX(1,2)*X(2)+EL%MATX(1,3)*X(5)/el%P%beta0
          T(2)=EL%MATX(2,1)*X(1)+EL%MATX(2,2)*X(2)+EL%MATX(2,3)*X(5)/el%P%beta0
          T(3)=EL%MATY(1,1)*X(3)+EL%MATY(1,2)*X(4)
          T(4)=EL%MATY(2,1)*X(3)+EL%MATY(2,2)*X(4)
          X(6)=X(6)+EL%LX(1)*X(1)/el%P%beta0+EL%LX(2)*X(2)/el%P%beta0+EL%LX(3)*X(5)
       ELSE
          T(1)=EL%MATX(1,1)*X(1)+EL%MATX(1,2)*X(2)+EL%MATX(1,3)*X(5)
          T(2)=EL%MATX(2,1)*X(1)+EL%MATX(2,2)*X(2)+EL%MATX(2,3)*X(5)
          T(3)=EL%MATY(1,1)*X(3)+EL%MATY(1,2)*X(4)
          T(4)=EL%MATY(2,1)*X(3)+EL%MATY(2,2)*X(4)
          X(6)=X(6)+EL%LX(1)*X(1)+EL%LX(2)*X(2)+EL%LX(3)*X(5)
       ENDIF
    ELSE
       IF(k%TIME) THEN
          T(1)=EL%RMATX(1,1)*X(1)+EL%RMATX(1,2)*X(2)+EL%RMATX(1,3)*X(5)/el%P%beta0
          T(2)=EL%RMATX(2,1)*X(1)+EL%RMATX(2,2)*X(2)+EL%RMATX(2,3)*X(5)/el%P%beta0
          T(3)=EL%RMATY(1,1)*X(3)+EL%RMATY(1,2)*X(4)
          T(4)=EL%RMATY(2,1)*X(3)+EL%RMATY(2,2)*X(4)
          X(6)=X(6)+EL%RLX(1)*X(1)/el%P%beta0+EL%RLX(2)*X(2)/el%P%beta0+EL%RLX(3)*X(5)
       ELSE
          T(1)=EL%RMATX(1,1)*X(1)+EL%RMATX(1,2)*X(2)+EL%RMATX(1,3)*X(5)
          T(2)=EL%RMATX(2,1)*X(1)+EL%RMATX(2,2)*X(2)+EL%RMATX(2,3)*X(5)
          T(3)=EL%RMATY(1,1)*X(3)+EL%RMATY(1,2)*X(4)
          T(4)=EL%RMATY(2,1)*X(3)+EL%RMATY(2,2)*X(4)
          X(6)=X(6)+EL%RLX(1)*X(1)+EL%RLX(2)*X(2)+EL%RLX(3)*X(5)
       ENDIF
    ENDIF

    X(1)=T(1);X(2)=T(2);X(3)=T(3);X(4)=T(4);

  END SUBROUTINE PUSHTKT7R

  SUBROUTINE PUSHTKT7D(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(TKTFP),INTENT(IN):: EL
    TYPE(REAL_8) T(4)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ALLOC(T,4)

    ! BUG FOUND BY SCHMIDT (SUBTLE ONE; AFFECTS PTC LOGIC; YUCK!)
    !    T(1)=EL%MATX(1,1)*X(1)+EL%MATX(1,2)*X(2)+EL%MATX(1,3)*X(5)
    !    T(2)=EL%MATX(2,1)*X(1)+EL%MATX(2,2)*X(2)+EL%MATX(2,3)*X(5)
    IF(EL%P%DIR*EL%P%CHARGE>0) THEN
       IF(k%TIME) THEN
          T(1)=EL%MATX(1,1)*X(1)+EL%MATX(1,2)*X(2)+EL%MATX(1,3)*X(5)/el%P%beta0
          T(2)=EL%MATX(2,1)*X(1)+EL%MATX(2,2)*X(2)+EL%MATX(2,3)*X(5)/el%P%beta0
          T(3)=EL%MATY(1,1)*X(3)+EL%MATY(1,2)*X(4)
          T(4)=EL%MATY(2,1)*X(3)+EL%MATY(2,2)*X(4)
          X(6)=X(6)+EL%LX(1)*X(1)/el%P%beta0+EL%LX(2)*X(2)/el%P%beta0+EL%LX(3)*X(5)
       ELSE
          T(1)=EL%MATX(1,1)*X(1)+EL%MATX(1,2)*X(2)+EL%MATX(1,3)*X(5)
          T(2)=EL%MATX(2,1)*X(1)+EL%MATX(2,2)*X(2)+EL%MATX(2,3)*X(5)
          T(3)=EL%MATY(1,1)*X(3)+EL%MATY(1,2)*X(4)
          T(4)=EL%MATY(2,1)*X(3)+EL%MATY(2,2)*X(4)
          X(6)=X(6)+EL%LX(1)*X(1)+EL%LX(2)*X(2)+EL%LX(3)*X(5)
       ENDIF
    ELSE
       IF(k%TIME) THEN
          T(1)=EL%RMATX(1,1)*X(1)+EL%RMATX(1,2)*X(2)+EL%RMATX(1,3)*X(5)/el%P%beta0
          T(2)=EL%RMATX(2,1)*X(1)+EL%RMATX(2,2)*X(2)+EL%RMATX(2,3)*X(5)/el%P%beta0
          T(3)=EL%RMATY(1,1)*X(3)+EL%RMATY(1,2)*X(4)
          T(4)=EL%RMATY(2,1)*X(3)+EL%RMATY(2,2)*X(4)
          X(6)=X(6)+EL%RLX(1)*X(1)/el%P%beta0+EL%RLX(2)*X(2)/el%P%beta0+EL%RLX(3)*X(5)
       ELSE
          T(1)=EL%RMATX(1,1)*X(1)+EL%RMATX(1,2)*X(2)+EL%RMATX(1,3)*X(5)
          T(2)=EL%RMATX(2,1)*X(1)+EL%RMATX(2,2)*X(2)+EL%RMATX(2,3)*X(5)
          T(3)=EL%RMATY(1,1)*X(3)+EL%RMATY(1,2)*X(4)
          T(4)=EL%RMATY(2,1)*X(3)+EL%RMATY(2,2)*X(4)
          X(6)=X(6)+EL%RLX(1)*X(1)+EL%RLX(2)*X(2)+EL%RLX(3)*X(5)
       ENDIF
    ENDIF

    X(1)=T(1);X(2)=T(2);X(3)=T(3);X(4)=T(4);

    CALL KILL(T,4)

  END SUBROUTINE PUSHTKT7D

  !***********************************************************************
  ! ALMOST SAME AS ELEMENT KTK AND KTKP (POLYMORPH) CUT AND PASTE PLEASE *
  !***********************************************************************
  SUBROUTINE KICKTKT7R(EL,YL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(TKTF),INTENT(IN):: EL
    real(dp),INTENT(IN):: YL
    real(dp) X1,X3,X5,BBYTW,BBXTW,BBYTWT
    INTEGER J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    DIR=EL%P%DIR*EL%P%CHARGE

    X1=X(1)
    X3=X(3)

    if(k%TIME) then
       X5=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)-1.0_dp
       X(2)=X(2)+YL*EL%P%B0*(X5-X(5)/EL%P%BETA0)
       X(6)=X(6)+YL*EL%P%B0*(  (X(5)+1.0_dp/EL%P%beta0)/(1.0_dp+X5) - 1.0_dp/EL%P%beta0  )*X(1)
    else
       X5=X(5)
    endif


    IF(EL%P%NMUL>=1) THEN
       BBYTW=EL%BN(EL%P%NMUL)
       BBXTW=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,1,-1
          BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
          BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
          BBYTW=BBYTWT
       ENDDO
    ELSE
       BBYTW=0.0_dp
       BBXTW=0.0_dp
    ENDIF

    X(2)=X(2)-YL*DIR*(BBYTW-DIR*EL%P%B0-EL%BN(2)*X(1))
    X(4)=X(4)+YL*DIR*(BBXTW-EL%BN(2)*X(3))

    !outvalishev    if(valishev.and.ABS(el%VS)>eps)   then  !valishev
    !outvalishev     call elliptical_b(el%VA,el%VS,x,BBXTW,BBYTW) !valishev
    !outvalishev       X(2)=X(2)-YL*DIR*BBYTW !valishev
    !outvalishev       X(4)=X(4)+YL* DIR*BBXTW !valishev
    !outvalishev    endif !valishev

  END SUBROUTINE KICKTKT7R



  SUBROUTINE KICKTKT7P(EL,YL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(TKTFP),INTENT(IN):: EL
    TYPE(REAL_8),INTENT(IN):: YL
    TYPE(REAL_8) X1,X3,X5,BBYTW,BBXTW,BBYTWT
    INTEGER J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    DIR=EL%P%DIR*EL%P%CHARGE


    CALL ALLOC(X1)
    CALL ALLOC(X3)
    CALL ALLOC(X5)
    CALL ALLOC(BBYTW)
    CALL ALLOC(BBXTW)
    CALL ALLOC(BBYTWT)


    X1=X(1)
    X3=X(3)

    if(k%TIME) then
       X5=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)-1.0_dp
       X(2)=X(2)+YL*EL%P%B0*(X5-X(5)/EL%P%BETA0)
       X(6)=X(6)+YL*EL%P%B0*( (X(5)+1.0_dp/EL%P%beta0)/(1.0_dp+X5) - 1.0_dp/EL%P%beta0  )*X(1)
    else
       X5=X(5)
    endif


    IF(EL%P%NMUL>=1) THEN
       BBYTW=EL%BN(EL%P%NMUL)
       BBXTW=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,1,-1
          BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
          BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
          BBYTW=BBYTWT
       ENDDO
    ELSE
       BBYTW=0.0_dp
       BBXTW=0.0_dp
    ENDIF

    X(2)=X(2)-YL*DIR*(BBYTW-DIR*EL%P%B0-EL%BN(2)*X(1))
    X(4)=X(4)+YL*DIR*(BBXTW-EL%BN(2)*X(3))

    !outvalishev    if(valishev.and.ABS(el%VS)>eps)   then  !valishev
    !outvalishev     call elliptical_b(el%VA,el%VS,x,BBXTW,BBYTW) !valishev
    !outvalishev       X(2)=X(2)-YL*DIR*BBYTW !valishev
    !outvalishev       X(4)=X(4)+YL* DIR*BBXTW !valishev
    !outvalishev    endif !valishev


    CALL KILL(X1)
    CALL KILL(X3)
    CALL KILL(X5)
    CALL KILL(BBYTW)
    CALL KILL(BBXTW)
    CALL KILL(BBYTWT)

  END SUBROUTINE KICKTKT7P


  SUBROUTINE KICKPATH6R(EL,YL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(KTK),INTENT(IN):: EL
    real(dp),INTENT(IN):: YL
    real(dp) PZ,PZ0
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    ! ETIENNE
    IF(.NOT.EL%P%EXACT) RETURN
    if(k%TIME) then
       PZ=root(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2-X(2)**2-X(4)**2)
       PZ0=root(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
       X(6)=X(6)+YL*(1.0_dp/EL%P%beta0+x(5))*(X(2)**2+X(4)**2)*(1.0_dp/PZ/(PZ+PZ0)-1.0_dp/PZ0**2/2.0_dp) &
            &     /PZ0
       PZ=(X(2)**2+X(4)**2)/PZ/PZ0/(PZ+PZ0)   ! = (one/PZ-one/PZ0)
       X(1)=X(1)+YL*X(2)*PZ
       X(3)=X(3)+YL*X(4)*PZ
    else
       PZ=root((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
       PZ0=1.0_dp+X(5)
       X(6)=X(6)+YL*(X(2)**2+X(4)**2)*(1.0_dp/PZ/(PZ+PZ0)-1.0_dp/PZ0**2/2.0_dp)
       PZ=(X(2)**2+X(4)**2)/PZ/PZ0/(PZ+PZ0)   ! = (one/PZ-one/PZ0)
       X(1)=X(1)+YL*X(2)*PZ
       X(3)=X(3)+YL*X(4)*PZ
    endif

  END SUBROUTINE KICKPATH6R

  SUBROUTINE KICKPATH6P(EL,YL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(KTKP),INTENT(IN):: EL
    TYPE(REAL_8),INTENT(IN):: YL
    TYPE(REAL_8) PZ,PZ0
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    ! ETIENNE
    IF(.NOT.EL%P%EXACT) RETURN
    CALL ALLOC(PZ,PZ0)
    if(k%TIME) then
       PZ=sqrt(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2-X(2)**2-X(4)**2)
       PZ0=sqrt(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
       X(6)=X(6)+YL*(1.0_dp/EL%P%beta0+x(5))*(X(2)**2+X(4)**2)*(1.0_dp/PZ/(PZ+PZ0)-1.0_dp/PZ0**2/2.0_dp) &
            &     /PZ0
       PZ=(X(2)**2+X(4)**2)/PZ/PZ0/(PZ+PZ0)   ! = (one/PZ-one/PZ0)
       X(1)=X(1)+YL*X(2)*PZ
       X(3)=X(3)+YL*X(4)*PZ
    else
       PZ=sqrt((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
       PZ0=1.0_dp+X(5)
       X(6)=X(6)+YL*(X(2)**2+X(4)**2)*(1.0_dp/PZ/(PZ+PZ0)-1.0_dp/PZ0**2/2.0_dp)
       PZ=(X(2)**2+X(4)**2)/PZ/PZ0/(PZ+PZ0)   ! = (one/PZ-one/PZ0)
       X(1)=X(1)+YL*X(2)*PZ
       X(3)=X(3)+YL*X(4)*PZ
    endif
    CALL KILL(PZ,PZ0)

  END SUBROUTINE KICKPATH6P

  SUBROUTINE KICKPATHR(EL,YL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(TKTF),INTENT(IN):: EL
    real(dp),INTENT(IN):: YL
    real(dp) X1,X5,PZ
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    ! ETIENNE
    if(k%TIME) then
       if(EL%P%EXACT) THEN
          PZ=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2-X(2)**2-X(4)**2)
          X(1)=X(1)+YL*X(2)*(1.0_dp/PZ-1.0_dp)
          X(3)=X(3)+YL*X(4)*(1.0_dp/PZ-1.0_dp)
          X(6)=X(6)+YL*(1.0_dp/EL%P%beta0+x(5))/PZ-YL*(1-k%TOTALPATH)/EL%P%beta0
       ELSE
          X5=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)-1.0_dp
          X1=(X(5)+1.0_dp/EL%P%BETA0)/(1.0_dp+X5)
          X(1)=X(1)-X5*YL*X(2)/(1.0_dp+X5)
          X(3)=X(3)-X5*YL*X(4)/(1.0_dp+X5)
          ! BUG FOUND BY SCHMIDT
          !       X(6)=X(6)+X1*YL*( k%TOTALPATH + (X(2)**2+X(4)**2)/two/(one+X5)**2 )
          X(6)=X(6)+X1*YL*( 1.0_dp + (X(2)**2+X(4)**2)/2.0_dp/(1.0_dp+X5)**2 )-YL*(1-k%TOTALPATH)/EL%P%beta0

       ENDIF
    else
       if(EL%P%EXACT) THEN
          PZ=ROOT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          X(1)=X(1)+YL*X(2)*(1.0_dp/PZ-1.0_dp)
          X(3)=X(3)+YL*X(4)*(1.0_dp/PZ-1.0_dp)
          X(6)=X(6)+YL*(1.0_dp+x(5))/PZ-YL*(1-k%TOTALPATH)
       ELSE
          X(1)=X(1)-X(5)*YL*X(2)/(1.0_dp+X(5))
          X(3)=X(3)-X(5)*YL*X(4)/(1.0_dp+X(5))
          X(6)=X(6)+YL*( k%TOTALPATH + (X(2)**2+X(4)**2)/2.0_dp/(1.0_dp+X(5))**2 )

       endif
    endif

  END SUBROUTINE KICKPATHR

  SUBROUTINE KICKPATHD(EL,YL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(TKTFP),INTENT(IN):: EL
    TYPE(REAL_8),INTENT(IN):: YL
    TYPE(REAL_8) X1,X5,PZ
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    if(k%TIME) then
       if(EL%P%EXACT) THEN
          CALL ALLOC(PZ)
          PZ=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2-X(2)**2-X(4)**2)
          X(1)=X(1)+YL*X(2)*(1.0_dp/PZ-1.0_dp)
          X(3)=X(3)+YL*X(4)*(1.0_dp/PZ-1.0_dp)
          X(6)=X(6)+YL*(1.0_dp/EL%P%beta0+x(5))/PZ-YL*(1-k%TOTALPATH)/EL%P%beta0
          CALL KILL(PZ)
       ELSE
          CALL ALLOC(X1,X5)
          X5=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)-1.0_dp
          X1=(X(5)+1.0_dp/EL%P%BETA0)/(1.0_dp+X5)
          X(1)=X(1)-X5*YL*X(2)/(1.0_dp+X5)
          X(3)=X(3)-X5*YL*X(4)/(1.0_dp+X5)
          ! BUG FOUND BY SCHMIDT
          !       X(6)=X(6)+X1*YL*( k%TOTALPATH + (X(2)**2+X(4)**2)/two/(one+X5)**2 )
          X(6)=X(6)+X1*YL*( 1.0_dp + (X(2)**2+X(4)**2)/2.0_dp/(1.0_dp+X5)**2 )-YL*(1-k%TOTALPATH)/EL%P%beta0

          CALL KILL(X1,X5)
       ENDIF
    else
       if(EL%P%EXACT) THEN
          CALL ALLOC(PZ)
          PZ=SQRT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          X(1)=X(1)+YL*X(2)*(1.0_dp/PZ-1.0_dp)
          X(3)=X(3)+YL*X(4)*(1.0_dp/PZ-1.0_dp)
          X(6)=X(6)+YL*(1.0_dp+x(5))/PZ-YL*(1-k%TOTALPATH)
          CALL KILL(PZ)
       ELSE
          X(1)=X(1)-X(5)*YL*X(2)/(1.0_dp+X(5))
          X(3)=X(3)-X(5)*YL*X(4)/(1.0_dp+X(5))
          X(6)=X(6)+YL*( k%TOTALPATH + (X(2)**2+X(4)**2)/2.0_dp/(1.0_dp+X(5))**2 )
       endif

    endif

  END SUBROUTINE KICKPATHD

  SUBROUTINE INTER_TKTF(EL,X,k,pos)
    IMPLICIT NONE
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(TKTF),INTENT(INOUT):: EL
    integer,optional :: pos
    INTEGER f1
    real(dp) DK,DK2,DK6,DK4,DK5
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    !   if(.not.CHECK_STABLE) return
    !   if(s_aperture_CHECK.and.associated(el%p%A).AND.CHECK_MADX_APERTURE)  &
    !    call check_S_APERTURE(el%p,pos,x)

    SELECT CASE(EL%P%METHOD)
    CASE(1)
       if(EL%F==1) then
          f1=0
       else
          f1=EL%F+1
       endif
       DK2=EL%L/(EL%P%NST/EL%F/2)
       DK=DK2/2.0_dp

       IF(MOD(POS,2*EL%F)==f1) THEN
          CALL KICKPATH(EL,DK,X,k)
          CALL KICKTKT7(EL,DK2,X,k)
          CALL KICKPATH(EL,DK,X,k)
       ENDIF
       CALL PUSHTKT7(EL,X,k)
    CASE(2)
       DK2=EL%L/EL%P%NST
       DK=DK2/2.0_dp

       CALL PUSHTKT7(EL,X,k)
       CALL KICKPATH(EL,DK,X,k)
       CALL KICKTKT7(EL,DK2,X,k)
       CALL KICKPATH(EL,DK,X,k)
       CALL PUSHTKT7(EL,X,k)

    CASE(3)

       if(EL%F==1) then
          f1=0
       else
          f1=EL%F+1
       endif
       DK=EL%L/(EL%P%NST/EL%F/2)/6.0_dp
       DK2=DK*2.0_dp
       DK6=2.0_dp*DK2

       if(mod(pos,EL%F*2)==F1) then
          CALL KICKPATH(EL,DK2,X,k)
          CALL KICKTKT7(EL,DK6,X,k)    ! 2/3
          CALL KICKPATH(EL,DK2,X,k)
          CALL PUSHTKT7(EL,X,k)
          if(f1==0.and.pos==EL%P%NST) then   ! this becomes nst
             CALL KICKPATH(EL,DK,X,k)
             CALL KICKTKT7(EL,DK,X,k)
          endif
       elseif(mod(pos,EL%F*2)==1.and.pos/=1) then
          CALL KICKPATH(EL,DK,X,k)
          CALL KICKTKT7(EL,DK2,X,k)    ! 1/3
          CALL KICKPATH(EL,DK,X,k)
          CALL PUSHTKT7(EL,X,k)
       elseif(pos==1) then             ! 1/6
          CALL KICKTKT7(EL,DK,X,k)
          CALL KICKPATH(EL,DK,X,k)
          CALL PUSHTKT7(EL,X,k)
       elseif(pos==EL%P%NST) then             ! 1/6
          CALL PUSHTKT7(EL,X,k)
          CALL KICKPATH(EL,DK,X,k)
          CALL KICKTKT7(EL,DK,X,k)
       else
          CALL PUSHTKT7(EL,X,k)
       endif


    CASE(4)
       DK2=EL%L/EL%P%NST/3.0_dp
       DK6=2.0_dp*DK2
       DK=DK2/2.0_dp

       CALL KICKTKT7(EL,DK,X,k)    ! NEW
       CALL KICKPATH(EL,DK,X,k)
       CALL PUSHTKT7(EL,X,k)
       CALL KICKPATH(EL,DK2,X,k)
       CALL KICKTKT7(EL,DK6,X,k)

       CALL KICKPATH(EL,DK2,X,k)
       CALL PUSHTKT7(EL,X,k)
       CALL KICKPATH(EL,DK,X,k)
       CALL KICKTKT7(EL,DK,X,k) ! NEW

    CASE(5)

       if(EL%F==1) then
          f1=0
       else
          f1=3*EL%F+1
       endif

       DK2=14.0_dp*EL%L/(EL%P%NST/EL%F/4)/90.0_dp  ! 14/90
       DK4=32.0_dp*EL%L/(EL%P%NST/EL%F/4)/90.0_dp  ! 32/90
       DK6=12.0_dp*EL%L/(EL%P%NST/EL%F/4)/90.0_dp  ! 12/90
       DK5=DK6/2.0_dp  ! 6/90
       DK=DK2/2.0_dp    ! 7/90

       if(mod(pos,EL%F*4)==EL%F+1) then
          CALL KICKTKT7(EL,DK4,X,k)  ! 32/90
          CALL KICKPATH(EL,DK4,X,k)  ! 32/90
          CALL PUSHTKT7(EL,X,k)
       elseif(mod(pos,EL%F*4)==f1) then
          CALL KICKPATH(EL,DK4,X,k)  ! 32/90
          CALL KICKTKT7(EL,DK4,X,k)  ! 32/90
          CALL PUSHTKT7(EL,X,k)
          if(f1==0.and.pos==EL%P%NST) then   ! this becomes nst
             CALL KICKPATH(EL,DK,X,k)  ! 7/90
             CALL KICKTKT7(EL,DK,X,k) !  7/90
          endif
       elseif(mod(pos,EL%F*4)==2*EL%F+1) then
          CALL KICKPATH(EL,DK5,X,k)  ! 6/90
          CALL KICKTKT7(EL,DK6,X,k)  ! 12/90
          CALL KICKPATH(EL,DK5,X,k)  ! 6/90
          CALL PUSHTKT7(EL,X,k)
       elseif(mod(pos,EL%F*4)==1.and.pos/=1) then
          CALL KICKPATH(EL,DK,X,k)  ! 7/90
          CALL KICKTKT7(EL,DK2,X,k) ! 14/90
          CALL KICKPATH(EL,DK,X,k)  ! 7/90
          CALL PUSHTKT7(EL,X,k)
       elseif(pos==1) then
          CALL KICKTKT7(EL,DK,X,k)  ! 7/90
          CALL KICKPATH(EL,DK,X,k)  ! 7/90
          CALL PUSHTKT7(EL,X,k)
       elseif(pos==EL%P%NST) then
          CALL PUSHTKT7(EL,X,k)
          CALL KICKPATH(EL,DK,X,k)  ! 7/90
          CALL KICKTKT7(EL,DK,X,k) !  7/90
       else
          CALL PUSHTKT7(EL,X,k)
       endif

    CASE(6)
       DK2=14.0_dp*EL%L/EL%P%NST/90.0_dp  ! 14/90
       DK4=32.0_dp*EL%L/EL%P%NST/90.0_dp  ! 32/90
       DK6=12.0_dp*EL%L/EL%P%NST/90.0_dp  ! 12/90
       DK5=DK6/2.0_dp  ! 6/90
       DK=DK2/2.0_dp    ! 7/90

       CALL KICKTKT7(EL,DK,X,k)  ! NEW
       CALL KICKPATH(EL,DK,X,k)

       CALL PUSHTKT7(EL,X,k)

       CALL KICKTKT7(EL,DK4,X,k)
       CALL KICKPATH(EL,DK4,X,k)

       CALL PUSHTKT7(EL,X,k)

       CALL KICKPATH(EL,DK5,X,k)
       CALL KICKTKT7(EL,DK6,X,k)   ! SYMMETRY POINT

       CALL KICKPATH(EL,DK5,X,k)

       CALL PUSHTKT7(EL,X,k)

       CALL KICKPATH(EL,DK4,X,k)
       CALL KICKTKT7(EL,DK4,X,k)

       CALL PUSHTKT7(EL,X,k)
       CALL KICKPATH(EL,DK,X,k)
       CALL KICKTKT7(EL,DK,X,k)  ! NEW

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT
    !       if(s_aperture_CHECK.and.associated(el%p%A).AND.CHECK_MADX_APERTURE) &
    !       call check_S_APERTURE_out(el%p,pos,x)

  END SUBROUTINE INTER_TKTF

  SUBROUTINE INTEP_TKTF(EL,X,k,pos)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(TKTFP),INTENT(INOUT):: EL
    integer,optional :: pos
    INTEGER f1
    TYPE(REAL_8) DK,DK2,DK6,DK4,DK5
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K



    SELECT CASE(EL%P%METHOD)
    CASE(1)
       CALL ALLOC(DK,DK2)
       if(EL%F==1) then
          f1=0
       else
          f1=EL%F+1
       endif
       DK2=EL%L/(EL%P%NST/EL%F/2)
       DK=DK2/2.0_dp

       IF(MOD(POS,2*EL%F)==f1) THEN
          CALL KICKPATH(EL,DK,X,k)
          CALL KICKTKT7(EL,DK2,X,k)
          CALL KICKPATH(EL,DK,X,k)
       ENDIF
       CALL PUSHTKT7(EL,X,k)
       CALL KILL(DK,DK2)
    CASE(2)
       CALL ALLOC(DK,DK2)

       DK2=EL%L/EL%P%NST
       DK=DK2/2.0_dp

       CALL PUSHTKT7(EL,X,k)
       CALL KICKPATH(EL,DK,X,k)
       CALL KICKTKT7(EL,DK2,X,k)
       CALL KICKPATH(EL,DK,X,k)
       CALL PUSHTKT7(EL,X,k)


       CALL KILL(DK,DK2)

    CASE(3)

       CALL ALLOC(DK,DK2,DK6)

       if(EL%F==1) then
          f1=0
       else
          f1=EL%F+1
       endif
       DK=EL%L/(EL%P%NST/EL%F/2)/6.0_dp
       DK2=DK*2.0_dp
       DK6=2.0_dp*DK2

       if(mod(pos,EL%F*2)==F1) then
          CALL KICKPATH(EL,DK2,X,k)
          CALL KICKTKT7(EL,DK6,X,k)    ! 2/3
          CALL KICKPATH(EL,DK2,X,k)
          CALL PUSHTKT7(EL,X,k)
          if(f1==0.and.pos==EL%P%NST) then   ! this becomes nst
             CALL KICKPATH(EL,DK,X,k)
             CALL KICKTKT7(EL,DK,X,k)
          endif
       elseif(mod(pos,EL%F*2)==1.and.pos/=1) then
          CALL KICKPATH(EL,DK,X,k)
          CALL KICKTKT7(EL,DK2,X,k)    ! 1/3
          CALL KICKPATH(EL,DK,X,k)
          CALL PUSHTKT7(EL,X,k)
       elseif(pos==1) then             ! 1/6
          CALL KICKTKT7(EL,DK,X,k)
          CALL KICKPATH(EL,DK,X,k)
          CALL PUSHTKT7(EL,X,k)
       elseif(pos==EL%P%NST) then             ! 1/6
          CALL PUSHTKT7(EL,X,k)
          CALL KICKPATH(EL,DK,X,k)
          CALL KICKTKT7(EL,DK,X,k)
       else
          CALL PUSHTKT7(EL,X,k)
       endif

       CALL KILL(DK,DK2,DK6)

    CASE(4)
       CALL ALLOC(DK,DK2,DK6)

       DK2=EL%L/EL%P%NST/3.0_dp
       DK6=2.0_dp*DK2
       DK=DK2/2.0_dp

       CALL KICKTKT7(EL,DK,X,k)    ! NEW
       CALL KICKPATH(EL,DK,X,k)
       CALL PUSHTKT7(EL,X,k)
       CALL KICKPATH(EL,DK2,X,k)
       CALL KICKTKT7(EL,DK6,X,k)

       CALL KICKPATH(EL,DK2,X,k)
       CALL PUSHTKT7(EL,X,k)
       CALL KICKPATH(EL,DK,X,k)
       CALL KICKTKT7(EL,DK,X,k) ! NEW

       CALL KILL(DK,DK2,DK6)

    CASE(5)

       CALL ALLOC(DK,DK2,DK6,DK4,DK5)
       if(EL%F==1) then
          f1=0
       else
          f1=3*EL%F+1
       endif

       DK2=14.0_dp*EL%L/(EL%P%NST/EL%F/4)/90.0_dp  ! 14/90
       DK4=32.0_dp*EL%L/(EL%P%NST/EL%F/4)/90.0_dp  ! 32/90
       DK6=12.0_dp*EL%L/(EL%P%NST/EL%F/4)/90.0_dp  ! 12/90
       DK5=DK6/2.0_dp  ! 6/90
       DK=DK2/2.0_dp    ! 7/90

       if(mod(pos,EL%F*4)==EL%F+1) then
          CALL KICKTKT7(EL,DK4,X,k)  ! 32/90
          CALL KICKPATH(EL,DK4,X,k)  ! 32/90
          CALL PUSHTKT7(EL,X,k)
       elseif(mod(pos,EL%F*4)==f1) then
          CALL KICKPATH(EL,DK4,X,k)  ! 32/90
          CALL KICKTKT7(EL,DK4,X,k)  ! 32/90
          CALL PUSHTKT7(EL,X,k)
          if(f1==0.and.pos==EL%P%NST) then   ! this becomes nst
             CALL KICKPATH(EL,DK,X,k)  ! 7/90
             CALL KICKTKT7(EL,DK,X,k) !  7/90
          endif
       elseif(mod(pos,EL%F*4)==2*EL%F+1) then
          CALL KICKPATH(EL,DK5,X,k)  ! 6/90
          CALL KICKTKT7(EL,DK6,X,k)  ! 12/90
          CALL KICKPATH(EL,DK5,X,k)  ! 6/90
          CALL PUSHTKT7(EL,X,k)
       elseif(mod(pos,EL%F*4)==1.and.pos/=1) then
          CALL KICKPATH(EL,DK,X,k)  ! 7/90
          CALL KICKTKT7(EL,DK2,X,k) ! 14/90
          CALL KICKPATH(EL,DK,X,k)  ! 7/90
          CALL PUSHTKT7(EL,X,k)
       elseif(pos==1) then
          CALL KICKTKT7(EL,DK,X,k)  ! 7/90
          CALL KICKPATH(EL,DK,X,k)  ! 7/90
          CALL PUSHTKT7(EL,X,k)
       elseif(pos==EL%P%NST) then
          CALL PUSHTKT7(EL,X,k)
          CALL KICKPATH(EL,DK,X,k)  ! 7/90
          CALL KICKTKT7(EL,DK,X,k) !  7/90
       else
          CALL PUSHTKT7(EL,X,k)
       endif
       CALL KILL(DK,DK2,DK6,DK4,DK5)

    CASE(6)
       CALL ALLOC(DK,DK2,DK6,DK4,DK5)

       DK2=14.0_dp*EL%L/EL%P%NST/90.0_dp
       DK4=32.0_dp*EL%L/EL%P%NST/90.0_dp
       DK6=12.0_dp*EL%L/EL%P%NST/90.0_dp
       DK5=DK6/2.0_dp
       DK=DK2/2.0_dp

       CALL KICKTKT7(EL,DK,X,k)  ! NEW
       CALL KICKPATH(EL,DK,X,k)

       CALL PUSHTKT7(EL,X,k)

       CALL KICKTKT7(EL,DK4,X,k)
       CALL KICKPATH(EL,DK4,X,k)

       CALL PUSHTKT7(EL,X,k)

       CALL KICKPATH(EL,DK5,X,k)
       CALL KICKTKT7(EL,DK6,X,k)   ! SYMMETRY POINT

       CALL KICKPATH(EL,DK5,X,k)

       CALL PUSHTKT7(EL,X,k)

       CALL KICKPATH(EL,DK4,X,k)
       CALL KICKTKT7(EL,DK4,X,k)

       CALL PUSHTKT7(EL,X,k)
       CALL KICKPATH(EL,DK,X,k)
       CALL KICKTKT7(EL,DK,X,k)  ! NEW

       CALL KILL(DK,DK2,DK6,DK4,DK5)

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

  END SUBROUTINE INTEP_TKTF

  SUBROUTINE INTTKT7R(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(TKTF),INTENT(INOUT):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    DO I=1,EL%P%NST
       IF(.NOT.PRESENT(MID))CALL TRACK_SLICE(EL,X,k,I)
       IF(PRESENT(MID)) CALL XMID(MID,X,I)
    ENDDO


  END SUBROUTINE INTTKT7R

  SUBROUTINE INTTKT7D(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    ! TYPE(WORM_8),OPTIONAL,INTENT(INOUT):: MID
    TYPE(TKTFP),INTENT(INOUT):: EL
    INTEGER I
    logical(lp) BN,L
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF((EL%BN(2)%KIND==3.OR.EL%L%KIND==3).AND.KNOB) THEN
       CALL GETMAT7(EL)                                      ! RECOMPUTES ONLY IF KNOB (SPEED)
    ENDIF

    DO I=1,EL%P%NST
       CALL TRACK_SLICE(EL,X,k,I)
    ENDDO

    IF(KNOB) THEN
       BN=.FALSE.
       L=.FALSE.
       IF(EL%BN(2)%KIND==3) THEN
          BN=.TRUE.
       ENDIF
       IF(EL%L%KIND==3) THEN
          L=.TRUE.
       ENDIF
       IF(BN.OR.L) THEN
          EL%BN(2)%KIND=1
          EL%L%KIND=1
          CALL KILL(EL)                               ! RECOMPUTES ONLY IF KNOB (SPEED)
          CALL ALLOC(EL)                               ! KNOB IS REMOVED THE SLOW WAY(SPEED)
          CALL GETMAT7(EL)
          IF(BN) EL%BN(2)%KIND=3
          IF(L)  EL%L%KIND=3
       ENDIF
    ENDIF


  END SUBROUTINE INTTKT7D

  SUBROUTINE SYMPINTTKT7R(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(TKTF),INTENT(INOUT):: EL
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(.NOT.PRESENT(MID))CALL TRACK_FRINGE(EL7=EL,X=X,k=k,J=1)
    CALL INTTKT7(EL,X,k,MID)
    IF(.NOT.PRESENT(MID))CALL TRACK_FRINGE(EL7=EL,X=X,k=k,J=2)


  END SUBROUTINE SYMPINTTKT7R

  SUBROUTINE SYMPINTTKT7D(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(TKTFP),INTENT(INOUT):: EL
    ! TYPE(WORM_8),OPTIONAL,INTENT(INOUT):: MID
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    CALL TRACK_FRINGE(EL7=EL,X=X,k=k,J=1)
    CALL INTTKT7(EL,X,k)
    CALL TRACK_FRINGE(EL7=EL,X=X,k=k,J=2)

  END SUBROUTINE SYMPINTTKT7D

  SUBROUTINE EXPR7(H,MATOUT,LX)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: H(4,4),MATOUT(2,3),LX(3)
    real(dp) AD(4,4),TEMP(4,4)
    real(dp) NORM,NORM0,NORMAT,NORMAT0
    logical(lp) FIRST
    INTEGER I,J,K,N

    DO I=1,2
       DO J=1,3
          MATOUT(I,J)=0.0_dp
       ENDDO
    ENDDO
    DO I=1,3
       LX(I)=0.0_dp
    ENDDO

    DO I=1,4
       DO J=1,4
          AD(I,J)=0.0_dp
          TEMP(I,J)=0.0_dp
       ENDDO
    ENDDO
    MATOUT(1,1)=1.0_dp
    MATOUT(2,2)=1.0_dp
    AD(1,1)=1.0_dp
    AD(2,2)=1.0_dp
    AD(3,3)=1.0_dp
    AD(4,4)=1.0_dp
    FIRST=.TRUE.
    NORM=1e6_dp
    NORMAT=2e5_dp
    DO N=1,NMAXI
       !  COMPUTING H**N/N!
       DO I=1,4
          DO J=1,4
             DO K=1,4
                TEMP(I,K)=H(I,J)*AD(J,K)+TEMP(I,K)
             ENDDO
          ENDDO
       ENDDO
       NORM0=NORM
       NORMAT0=NORMAT
       !  ADDING TO MATOUT
       NORM=0.0_dp
       NORMAT=0.0_dp
       DO I=1,4   !2
          DO J=1,4
             AD(I,J)=TEMP(I,J)/N
             IF(I<3.AND.J<4)  THEN
                MATOUT(I,J)=MATOUT(I,J)+AD(I,J)
                NORMAT=NORMAT+ABS(MATOUT(I,J))
             ENDIF
             IF(I==4.AND.J<4) THEN
                LX(J)=LX(J)+AD(I,J)
                NORMAT=NORMAT+ABS(LX(J))
             ENDIF
             TEMP(I,J)=0.0_dp
          ENDDO
       ENDDO

       NORM=ABS(NORMAT-NORMAT0)


       IF(FIRST) THEN
          IF(NORM<EPS_DEF_KIND) THEN
             FIRST=.FALSE.
          ENDIF
       ELSE
          IF(NORM>=NORM0) GOTO 100
       ENDIF


    ENDDO

    w_p=0
    w_p%nc=1
    w_p%fc='(1(1X,A72))'
    write(w_p%c(1),'(A31,1X,I4,1X,A11)') " EXPSOLR FAILED TO CONVERGE IN ",NMAXI," ITERATIONS"
    ! call !write_e(0)

100 CONTINUE

  END SUBROUTINE EXPR7


  SUBROUTINE EXPD7(H,MATOUT,LX)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: H(4,4),MATOUT(2,3),LX(3)
    TYPE(REAL_8) AD(4,4),TEMP(4,4)
    real(dp) NORM,NORM0,NORMAT,NORMAT0
    logical(lp) FIRST
    INTEGER I,J,K,N

    DO I=1,2
       DO J=1,3
          MATOUT(I,J)=0.0_dp
       ENDDO
    ENDDO
    DO I=1,3
       LX(I)=0.0_dp
    ENDDO

    DO I=1,4
       DO J=1,4
          CALL ALLOC(AD(I,J))
          CALL ALLOC(TEMP(I,J))
       ENDDO
    ENDDO
    MATOUT(1,1)=1.0_dp
    MATOUT(2,2)=1.0_dp
    AD(1,1)=1.0_dp
    AD(2,2)=1.0_dp
    AD(3,3)=1.0_dp
    AD(4,4)=1.0_dp
    FIRST=.TRUE.
    NORM=1e6_dp
    NORMAT=2e5_dp
    DO N=1,NMAXI
       !  COMPUTING H**N/N!
       DO I=1,4
          DO J=1,4
             DO K=1,4
                TEMP(I,K)=H(I,J)*AD(J,K)+TEMP(I,K)
             ENDDO
          ENDDO
       ENDDO
       NORM0=NORM
       NORMAT0=NORMAT
       !  ADDING TO MATOUT
       NORM=0.0_dp
       NORMAT=0.0_dp
       DO I=1,4   !2
          DO J=1,4
             AD(I,J)=TEMP(I,J)/N

             IF(I<3.AND.J<4)  THEN
                MATOUT(I,J)=MATOUT(I,J)+AD(I,J)
                NORMAT=NORMAT+ABS(MATOUT(I,J))
             ENDIF
             IF(I==4.AND.J<4) THEN
                LX(J)=LX(J)+AD(I,J)
                NORMAT=NORMAT+ABS(LX(J))
             ENDIF
             TEMP(I,J)=0.0_dp
          ENDDO
       ENDDO
       NORM=ABS(NORMAT-NORMAT0)


       IF(FIRST) THEN
          IF(NORM<EPS_DEF_KIND) THEN
             FIRST=.FALSE.
          ENDIF
       ELSE
          IF(NORM>=NORM0) GOTO 100
       ENDIF


    ENDDO

    w_p=0
    w_p%nc=1
    w_p%fc='(1(1X,A72))'
    write(w_p%c(1),'(A31,1X,I4,1X,A11)') " EXPSOLR FAILED TO CONVERGE IN ",NMAXI," ITERATIONS"
    ! call !write_e(0)

100 CONTINUE

    DO I=1,4
       DO J=1,4
          CALL KILL(AD(I,J))
          CALL KILL(TEMP(I,J))
       ENDDO
    ENDDO


  END SUBROUTINE EXPD7

!!!!!!!!!!!!!!!!!!!!  the smi  !!!!!!!!!!!!!!!!!!!!!!!!!!!

  subroutine push_Nsmi_r(el,x,k,MID)
    implicit none
    TYPE (NSMI),INTENT(IN)::EL
    TYPE(WORM), OPTIONAL,INTENT(INOUT):: MID
    real(dp) ,INTENT(INOUT)::x(6)
    real(dp) ekk,CRKVE,CIKVE,CRKVEUK,XL,ZL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    XL=X(1)
    ZL=X(3)
    CRKVE=XL
    CIKVE=ZL

    EKK=-EL%P%DIR*EL%P%CHARGE*EL%BN(EL%P%NMUL)/2.0_dp                      ! ANTI-SIXTRACK UNIT

    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    select case(el%P%NMUL)


       !--HORIZONTAL DIPOLE
    case(1)
       X(2)=X(2)+EKK
       !--NORMAL QUADRUPOLE
    case(2)
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL SEXTUPOLE
    case(3)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !--NORMAL OCTUPOLE
    case(4)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !--NORMAL DECAPOLE
    case(5)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL DODECAPOL
    case(6)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 14-POL
    case(7)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 16-POL
    case(8)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 18-POL
    case(9)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 20-POL
    case(10)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
    END SELECT

    IF(PRESENT(MID)) CALL XMID(MID,X,1)

    select case(el%P%NMUL)


       !--HORIZONTAL DIPOLE
    case(1)
       X(2)=X(2)+EKK
       !--NORMAL QUADRUPOLE
    case(2)
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL SEXTUPOLE
    case(3)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !--NORMAL OCTUPOLE
    case(4)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !--NORMAL DECAPOLE
    case(5)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL DODECAPOL
    case(6)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 14-POL
    case(7)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 16-POL
    case(8)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 18-POL
    case(9)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 20-POL
    case(10)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
    END SELECT

    !    IF(PRESENT(MID)) CALL XMID(MID,X,2)

  end subroutine push_Nsmi_r

  subroutine push_Nsmi_D(el,x,k)
    implicit none
    TYPE (NSMIP),INTENT(IN)::EL
    ! TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: MID
    TYPE(real_8) ,INTENT(INOUT)::x(6)
    TYPE(real_8)ekk,CRKVE,CIKVE,CRKVEUK,XL,ZL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ALLOC(ekk);CALL ALLOC(CRKVE);CALL ALLOC(CIKVE);
    CALL ALLOC(CRKVEUK);CALL ALLOC(XL);CALL ALLOC(ZL);

    XL=X(1)
    ZL=X(3)
    CRKVE=XL
    CIKVE=ZL

    EKK=-EL%P%DIR*EL%P%CHARGE*EL%BN(EL%P%NMUL)/2.0_dp                      ! ANTI-SIXTRACK UNIT

    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    select case(el%P%NMUL)


       !--HORIZONTAL DIPOLE
    case(1)
       X(2)=X(2)+EKK
       !--NORMAL QUADRUPOLE
    case(2)
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL SEXTUPOLE
    case(3)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !--NORMAL OCTUPOLE
    case(4)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !--NORMAL DECAPOLE
    case(5)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL DODECAPOL
    case(6)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 14-POL
    case(7)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 16-POL
    case(8)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 18-POL
    case(9)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 20-POL
    case(10)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
    END SELECT

    !    IF(PRESENT(MID)) CALL XMID(MID,X,1)

    select case(el%P%NMUL)


       !--HORIZONTAL DIPOLE
    case(1)
       X(2)=X(2)+EKK
       !--NORMAL QUADRUPOLE
    case(2)
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL SEXTUPOLE
    case(3)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !--NORMAL OCTUPOLE
    case(4)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !--NORMAL DECAPOLE
    case(5)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL DODECAPOL
    case(6)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 14-POL
    case(7)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 16-POL
    case(8)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 18-POL
    case(9)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 20-POL
    case(10)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
    END SELECT

    !    IF(PRESENT(MID)) CALL XMID(MID,X,2)

    CALL KILL(ekk);CALL KILL(CRKVE);CALL KILL(CIKVE);
    CALL KILL(CRKVEUK);CALL KILL(XL);CALL KILL(ZL);



  end subroutine push_Nsmi_D

  subroutine push_Ssmi_r(el,x,k,MID)
    implicit none
    TYPE (SSMI),INTENT(IN)::EL
    TYPE(WORM), OPTIONAL,INTENT(INOUT):: MID
    real(dp) ,INTENT(INOUT)::x(6)
    real(dp) ekk,CRKVE,CIKVE,CRKVEUK,XL,ZL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    XL=X(1)
    ZL=X(3)
    CRKVE=XL
    CIKVE=ZL

    EKK=EL%P%DIR*EL%P%CHARGE*EL%AN(EL%P%NMUL)/2.0_dp
    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    select case(el%P%NMUL)

       !---VERTICAL DIPOLE
    CASE(1)
       X(4)=X(4)+EKK
       !---SKEW QUADRUPOLE
    CASE(2)
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW SEXTUPOLE
    CASE(3)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW OCTUPOLE
    CASE(4)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW DECAPOLE
    CASE(5)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW DODECAPOL
    CASE(6)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 14-POL
    CASE(7)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 16-POL
    CASE(8)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 18-POL
    CASE(9)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 20-POL
    CASE(10)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE

    END SELECT

    IF(PRESENT(MID)) CALL XMID(MID,X,1)

    select case(el%P%NMUL)

       !---VERTICAL DIPOLE
    CASE(1)
       X(4)=X(4)+EKK
       !---SKEW QUADRUPOLE
    CASE(2)
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW SEXTUPOLE
    CASE(3)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW OCTUPOLE
    CASE(4)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW DECAPOLE
    CASE(5)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW DODECAPOL
    CASE(6)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 14-POL
    CASE(7)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 16-POL
    CASE(8)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 18-POL
    CASE(9)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 20-POL
    CASE(10)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE

    END SELECT
    !    IF(PRESENT(MID)) CALL XMID(MID,X,2)

  end subroutine push_Ssmi_r

  subroutine push_Ssmi_D(el,x,k)
    implicit none
    TYPE (SSMIP),INTENT(IN)::EL
    ! TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: MID
    TYPE(real_8) ,INTENT(INOUT)::x(6)
    TYPE(real_8)ekk,CRKVE,CIKVE,CRKVEUK,XL,ZL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ALLOC(ekk);CALL ALLOC(CRKVE);CALL ALLOC(CIKVE);
    CALL ALLOC(CRKVEUK);CALL ALLOC(XL);CALL ALLOC(ZL);

    XL=X(1)
    ZL=X(3)
    CRKVE=XL
    CIKVE=ZL

    EKK=EL%P%DIR*EL%P%CHARGE*EL%AN(EL%P%NMUL)/2.0_dp
    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    select case(el%P%NMUL)

       !---VERTICAL DIPOLE
    CASE(1)
       X(4)=X(4)+EKK
       !---SKEW QUADRUPOLE
    CASE(2)
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW SEXTUPOLE
    CASE(3)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW OCTUPOLE
    CASE(4)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW DECAPOLE
    CASE(5)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW DODECAPOL
    CASE(6)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 14-POL
    CASE(7)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 16-POL
    CASE(8)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 18-POL
    CASE(9)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 20-POL
    CASE(10)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE

    END SELECT

    !    IF(PRESENT(MID)) CALL XMID(MID,X,1)

    select case(el%P%NMUL)

       !---VERTICAL DIPOLE
    CASE(1)
       X(4)=X(4)+EKK
       !---SKEW QUADRUPOLE
    CASE(2)
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW SEXTUPOLE
    CASE(3)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW OCTUPOLE
    CASE(4)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW DECAPOLE
    CASE(5)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW DODECAPOL
    CASE(6)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 14-POL
    CASE(7)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 16-POL
    CASE(8)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 18-POL
    CASE(9)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 20-POL
    CASE(10)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE

    END SELECT
    !    IF(PRESENT(MID)) CALL XMID(MID,X,2)

    CALL KILL(ekk);CALL KILL(CRKVE);CALL KILL(CIKVE);
    CALL KILL(CRKVEUK);CALL KILL(XL);CALL KILL(ZL);

  end subroutine push_Ssmi_D

!!!! *************************************************************** !!!!
!!!! *           Beginning of the teapot element                   * !!!!
!!!! *************************************************************** !!!!
  SUBROUTINE GETANBNR(EL)
    IMPLICIT NONE
    TYPE(TEAPOT),INTENT(INOUT):: EL
    INTEGER I,J,K,POW,nmul

    !    nmul=EL%P%NMUL
    !    IF(EL%P%NMUL> SECTOR_NMUL) THEN

    nmul=SECTOR_NMUL_max

    !    ENDIF

    DO I=1,S_B_from_V%N_MONO
       EL%BF_X(I)=0.0_dp
       EL%BF_Y(I)=0.0_dp
    ENDDO
    DO I=1,NMUL
       DO J=1,S_B_from_V%N_MONO
          K=S_B_from_V%I(J)+S_B_from_V%J(J)
          POW=K+1-I
          IF(K+1>=I) THEN


!             EL%BF_X(J)=EL%BF_X(J)+(EL%AN(I)*S_B%A_X(I,J)+EL%BN(I)*S_B%B_X(I,J))*EL%P%B0**POW
!             EL%BF_Y(J)=EL%BF_Y(J)+(EL%AN(I)*S_B%A_Y(I,J)+EL%BN(I)*S_B%B_Y(I,J))*EL%P%B0**POW
             EL%BF_X(J)=EL%BF_X(J)+(EL%AN(I)*S_B_from_V%A_X(I,J)+EL%BN(I)*S_B_from_V%B_X(I,J))*EL%P%B0**POW
             EL%BF_Y(J)=EL%BF_Y(J)+(EL%AN(I)*S_B_from_V%A_Y(I,J)+EL%BN(I)*S_B_from_V%B_Y(I,J))*EL%P%B0**POW

          ENDIF
       ENDDO
    ENDDO

    DO I=1,S_B_from_V%N_MONO
       EL%VM(I)=0.0_dp
    ENDDO

    DO I=1,NMUL
       DO J=1,S_B_from_V%N_MONO
          K=S_B_from_V%i(J)+S_B_from_V%j(J)
          POW=K-I      !+1
          IF(K>=I) THEN   ! changed

             EL%VM(J)=EL%VM(J)+(EL%An(I)*S_B_from_V%VA(I,J)+EL%Bn(I)*S_B_from_V%VB(I,J))*EL%P%B0**POW

          ENDIF
       ENDDO
    ENDDO




  END SUBROUTINE GETANBNR

  SUBROUTINE GETANBNP(EL)
    IMPLICIT NONE
    TYPE(TEAPOTP),INTENT(INOUT):: EL
    INTEGER I,J,K,POW,nmul

    !    nmul=EL%P%NMUL
    !    IF(EL%P%NMUL> SECTOR_NMUL) THEN

    nmul=SECTOR_NMUL_max

    !    ENDIF

    DO I=1,S_B_from_V%N_MONO
       EL%BF_X(I)=0.0_dp
       EL%BF_Y(I)=0.0_dp
    ENDDO
    DO I=1,NMUL
       DO J=1,S_B_from_V%N_MONO
          K=S_B_from_V%I(J)+S_B_from_V%J(J)
          POW=K+1-I
          IF(K+1>=I) THEN

!             EL%BF_X(J)=EL%BF_X(J)+(EL%AN(I)*S_B%A_X(I,J)+EL%BN(I)*S_B%B_X(I,J))*EL%P%B0**POW
!             EL%BF_Y(J)=EL%BF_Y(J)+(EL%AN(I)*S_B%A_Y(I,J)+EL%BN(I)*S_B%B_Y(I,J))*EL%P%B0**POW
             EL%BF_X(J)=EL%BF_X(J)+(EL%AN(I)*S_B_from_V%A_X(I,J)+EL%BN(I)*S_B_from_V%B_X(I,J))*EL%P%B0**POW
             EL%BF_Y(J)=EL%BF_Y(J)+(EL%AN(I)*S_B_from_V%A_Y(I,J)+EL%BN(I)*S_B_from_V%B_Y(I,J))*EL%P%B0**POW

          ENDIF
       ENDDO
    ENDDO

    DO I=1,S_B_from_V%N_MONO
       EL%VM(I)=0.0_dp
    ENDDO

    DO I=1,NMUL
       DO J=1,S_B_from_V%N_MONO
          K=S_B_from_V%i(J)+S_B_from_V%j(J)
          POW=K-I      !+1
          IF(K>=I) THEN   ! changed

             EL%VM(J)=EL%VM(J)+(EL%An(I)*S_B_from_V%VA(I,J)+EL%Bn(I)*S_B_from_V%VB(I,J))*EL%P%B0**POW

          ENDIF
       ENDDO
    ENDDO


  END SUBROUTINE GETANBNP

 SUBROUTINE GETAEBER(EL)
    IMPLICIT NONE
    TYPE(TEAPOT),INTENT(INOUT):: EL
    INTEGER I,J,K,POW,nmul

    !    nmul=EL%P%NMUL
    !    IF(EL%P%NMUL> SECTOR_NMUL) THEN

    nmul=SECTOR_NMUL_max

    !    ENDIF

    DO I=1,S_E%N_MONO
       EL%E_X(I)=0.0_dp
       EL%E_Y(I)=0.0_dp
       EL%BF_X(I)=0.0_dp
       EL%BF_Y(I)=0.0_dp
    ENDDO
    DO I=1,NMUL
       DO J=1,S_E%N_MONO
          K=S_E%I(J)+S_E%J(J)
          POW=K+1-I
  
          IF(K+1>=I) THEN

        if(el%p%exact.or.pow==0) then
             EL%E_X(J)=EL%E_X(J)+(EL%AE(I)*S_E%A_X(I,J)+EL%BE(I)*S_E%B_X(I,J))*EL%P%B0**POW
             EL%E_Y(J)=EL%E_Y(J)+(EL%AE(I)*S_E%A_Y(I,J)+EL%BE(I)*S_E%B_Y(I,J))*EL%P%B0**POW
!             EL%BF_X(J)=EL%BF_X(J)+(EL%AN(I)*S_EB%A_X(I,J)+EL%BN(I)*S_EB%B_X(I,J))*EL%P%B0**POW
!             EL%BF_Y(J)=EL%BF_Y(J)+(EL%AN(I)*S_EB%A_Y(I,J)+EL%BN(I)*S_EB%B_Y(I,J))*EL%P%B0**POW
             EL%BF_X(J)=EL%BF_X(J)+(EL%AN(I)*S_B_from_V%A_X(I,J)+EL%BN(I)*S_B_from_V%B_X(I,J))*EL%P%B0**POW
             EL%BF_Y(J)=EL%BF_Y(J)+(EL%AN(I)*S_B_from_V%A_Y(I,J)+EL%BN(I)*S_B_from_V%B_Y(I,J))*EL%P%B0**POW
        endif
        if(i==1.and.(.not.el%p%exact).and.pow>0) then
             EL%BF_X(J)=EL%BF_X(J)+(EL%BN(I)*S_B_from_V%B_X(I,J))*EL%P%B0**POW
             EL%BF_Y(J)=EL%BF_Y(J)+(EL%BN(I)*S_B_from_V%B_Y(I,J))*EL%P%B0**POW
        endif
          ENDIF
       ENDDO
    ENDDO

    DO I=1,S_E%N_MONO
       EL%PHI(I)=0.0_dp
       EL%VM(I)=0.0_dp
    ENDDO

    DO I=1,NMUL
       DO J=1,S_E%N_MONO
          K=S_E%i(J)+S_E%j(J)
          POW=K-I      !+1
          IF(K>=I) THEN   ! changed

        if(el%p%exact.or.pow==0) then
             EL%PHI(J)=EL%PHI(J)+(EL%AE(I)*S_E%VA(I,J)+EL%BE(I)*S_E%VB(I,J))*EL%P%B0**POW

             EL%VM(J)=EL%VM(J)+(EL%AN(I)*S_B_from_V%VA(I,J)+EL%BN(I)*S_B_from_V%VB(I,J))*EL%P%B0**POW
        endif

          ENDIF
       ENDDO
    ENDDO

  END SUBROUTINE GETAEBER

 SUBROUTINE GETAEBEP(EL)
    IMPLICIT NONE
    TYPE(TEAPOTP),INTENT(INOUT):: EL
    INTEGER I,J,K,POW,nmul

    !    nmul=EL%P%NMUL
    !    IF(EL%P%NMUL> SECTOR_NMUL) THEN

    nmul=SECTOR_NMUL_max

    !    ENDIF

    DO I=1,S_E%N_MONO
       EL%E_X(I)=0.0_dp
       EL%E_Y(I)=0.0_dp
       EL%BF_X(I)=0.0_dp
       EL%BF_Y(I)=0.0_dp
    ENDDO
    DO I=1,NMUL
       DO J=1,S_E%N_MONO
          K=S_E%I(J)+S_E%J(J)
          POW=K+1-I
          IF(K+1>=I) THEN

        if(el%p%exact.or.pow==0) then
             EL%E_X(J)=EL%E_X(J)+(EL%AE(I)*S_E%A_X(I,J)+EL%BE(I)*S_E%B_X(I,J))*EL%P%B0**POW
             EL%E_Y(J)=EL%E_Y(J)+(EL%AE(I)*S_E%A_Y(I,J)+EL%BE(I)*S_E%B_Y(I,J))*EL%P%B0**POW
!             EL%BF_X(J)=EL%BF_X(J)+(EL%AN(I)*S_EB%A_X(I,J)+EL%BN(I)*S_EB%B_X(I,J))*EL%P%B0**POW
!             EL%BF_Y(J)=EL%BF_Y(J)+(EL%AN(I)*S_EB%A_Y(I,J)+EL%BN(I)*S_EB%B_Y(I,J))*EL%P%B0**POW
             EL%BF_X(J)=EL%BF_X(J)+(EL%AN(I)*S_B_from_V%A_X(I,J)+EL%BN(I)*S_B_from_V%B_X(I,J))*EL%P%B0**POW
             EL%BF_Y(J)=EL%BF_Y(J)+(EL%AN(I)*S_B_from_V%A_Y(I,J)+EL%BN(I)*S_B_from_V%B_Y(I,J))*EL%P%B0**POW
        endif
        if(i==1.and.(.not.el%p%exact).and.pow>0) then
             EL%BF_X(J)=EL%BF_X(J)+(EL%BN(I)*S_B_from_V%B_X(I,J))*EL%P%B0**POW
             EL%BF_Y(J)=EL%BF_Y(J)+(EL%BN(I)*S_B_from_V%B_Y(I,J))*EL%P%B0**POW
        endif
          ENDIF
       ENDDO
    ENDDO

    DO I=1,S_E%N_MONO
       EL%PHI(I)=0.0_dp
       EL%VM(I)=0.0_dp
    ENDDO

    DO I=1,NMUL
       DO J=1,S_E%N_MONO
          K=S_E%i(J)+S_E%j(J)
          POW=K-I      !+1
          IF(K>=I) THEN   ! changed

        if(el%p%exact.or.pow==0) then
             EL%PHI(J)=EL%PHI(J)+(EL%AE(I)*S_E%VA(I,J)+EL%BE(I)*S_E%VB(I,J))*EL%P%B0**POW

             EL%VM(J)=EL%VM(J)+(EL%AN(I)*S_B_from_V%VA(I,J)+EL%BN(I)*S_B_from_V%VB(I,J))*EL%P%B0**POW
        endif

          ENDIF
       ENDDO
    ENDDO

  END SUBROUTINE GETAEBEP


 
 SUBROUTINE GETELECTRICR(EL,E,phi,B,VM,X,kick)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6),E(3),B(3),phi,VM  !  is actually the elecric field
    TYPE(TEAPOT),INTENT(IN):: EL
    real(dp) X1,X3,BX,BY,BTX,BTY,BtYT,phit,VMT
    real(dp) EX,ETX,EY,ETY 
    logical(lp), optional :: kick
    logical(lp) kic
    INTEGER J,M,A,K
!VM is the scalar potential of the magnetic field!!!!! 
    kic=my_false
    if(present(kick)) kic=kick

    X1=X(1)
    X3=X(3)

    BX=0.0_dp
    BY=0.0_dp
    EX=0.0_dp
    EY=0.0_dp
    phi=0.0_dp
    VM=0.0_dp

    k=0
    m=EL%P%nmul
    do a=m,1,-1
       ETX=0.0_dp
       ETY=0.0_dp
       BTX=0.0_dp
       BTY=0.0_dp
       phit=0.0_dp
       VMt=0.0_dp
       do j=m-a,1,-1
          k=k+1
          !b%i(k)=a
          !b%j(k)=j
          BTX= (BTX+EL%BF_X(k))*X3  !x1
          BTY= (BTY+EL%BF_Y(k))*X3
          ETX= (ETX+EL%E_X(k))*X3  !x1
          ETY= (ETY+EL%E_Y(k))*X3
          phit= (phit+EL%phi(k))*X3
          VMt= (VMt+EL%VM(k))*X3
       enddo

       k=k+1
       !  b%i(k)=a
       !  b%j(k)=0
       BTX= (BTX+EL%BF_X(k))
       BTY= (BTY+EL%BF_Y(k))
       ETX= (ETX+EL%E_X(k))
       ETY= (ETY+EL%E_Y(k))
       phit= (phit+EL%phi(k))
       VMt= (VMt+EL%VM(k))
       BX= (BX+BTX)*X1
       BY= (BY+BTY)*X1
       EX= (EX+ETX)*X1
       EY= (EY+ETY)*X1
       phi= (phi+phit)*X1
       VM= (VM+VMt)*X1
    enddo
    BTX=0.0_dp
    BTY=0.0_dp
    ETX=0.0_dp
    ETY=0.0_dp
    phit=0.0_dp
    VMt=0.0_dp
    do j=m,1,-1
       k=k+1
       !  b%i(k)=0
       !  b%j(k)=j
       BTX= (BTX+EL%BF_X(k))*X3
       BTY= (BTY+EL%BF_Y(k))*X3
       ETX= (ETX+EL%E_X(k))*X3
       ETY= (ETY+EL%E_Y(k))*X3
       phit= (phit+EL%phi(k))*X3
       VMt= (VMt+EL%VM(k))*X3
    enddo
    k=k+1
    !    b%i(k)=0
    !    b%j(k)=0
    BX= BX+BTX+EL%BF_X(k)  !+X3
    BY= BY+BTY+EL%BF_Y(k)  !+X3
    EX= EX+ETX+EL%E_X(k)  !+X3
    EY= EY+ETY+EL%E_Y(k)  !+X3
    phi= phi+phit+EL%phi(k)  !+X3
    VM= VM+VMt+EL%VM(k)  !+X3

 !   if(kic) then
 !    B(1)=BX 
 !    B(2)=BY 
 !    B(3)=0.0_dp
 !   else
 !    B(1)=BY/(1.0_dp+EL%P%B0*X(1))
 !    B(2)=-BX/(1.0_dp+EL%P%B0*X(1))
 !    B(3)=0.0_dp
 !   endif

    if(kic) then
     if(EL%P%exact) then
      B(1)=-BY*(1.0_dp+EL%P%B0*X(1))
      B(2)=BX*(1.0_dp+EL%P%B0*X(1))
    else
      B(1)=-BY-el%bn(1)*EL%P%B0*X(1) 
      B(2)=BX 
    endif
      B(3)=0.0_dp
    else
     B(1)=BX
     B(2)=BY
     B(3)=0.0_dp
    endif


    E(1)=Ex*volt_c/EL%P%P0C
    E(2)=Ey*volt_c/EL%P%P0C
    E(3)=0.0_dp
    phi=phi*volt_c/EL%P%P0C




  END SUBROUTINE GETELECTRICR
  

  SUBROUTINE GETELECTRICP(EL,E,phi,B,VM,X,kick)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6),B(3),E(3),phi,VM
    TYPE(TEAPOTP),INTENT(IN):: EL
    TYPE(REAL_8) X1,X3,BX,BY,BTX,BTY,BtYT 
    TYPE(REAL_8) phit,EX,ETX,EY,ETY,VMT
    logical(lp), optional :: kick
    logical(lp) kic
    INTEGER J,M,A,K
    kic=my_false
    if(present(kick)) kic=kick

    CALL ALLOC(X1,X3,BX,BY,BTX,BTY,BtYT)
    CALL ALLOC(phit,EX,ETX,EY,ETY,VMT)

    X1=X(1)
    X3=X(3)

    BX=0.0_dp
    BY=0.0_dp
    EX=0.0_dp
    EY=0.0_dp
    phi=0.0_dp
    VM=0.0_dp

    k=0
    m=EL%P%nmul
    do a=m,1,-1
       ETX=0.0_dp
       ETY=0.0_dp
       BTX=0.0_dp
       BTY=0.0_dp
       phit=0.0_dp
       VMt=0.0_dp
       do j=m-a,1,-1
          k=k+1
          !b%i(k)=a
          !b%j(k)=j
          BTX= (BTX+EL%BF_X(k))*X3  !x1
          BTY= (BTY+EL%BF_Y(k))*X3
          ETX= (ETX+EL%E_X(k))*X3  !x1
          ETY= (ETY+EL%E_Y(k))*X3
          phit= (phit+EL%phi(k))*X3
          VMt= (VMt+EL%VM(k))*X3
       enddo

       k=k+1
       !  b%i(k)=a
       !  b%j(k)=0
       BTX= (BTX+EL%BF_X(k))
       BTY= (BTY+EL%BF_Y(k))
       ETX= (ETX+EL%E_X(k))
       ETY= (ETY+EL%E_Y(k))
       phit= (phit+EL%phi(k))
       VMt= (VMt+EL%VM(k))
       BX= (BX+BTX)*X1
       BY= (BY+BTY)*X1
       EX= (EX+ETX)*X1
       EY= (EY+ETY)*X1
       phi= (phi+phit)*X1
       VM= (VM+VMT)*X1
    enddo
    BTX=0.0_dp
    BTY=0.0_dp
    ETX=0.0_dp
    ETY=0.0_dp
    phit=0.0_dp
    VMt=0.0_dp
    do j=m,1,-1
       k=k+1
       !  b%i(k)=0
       !  b%j(k)=j
       BTX= (BTX+EL%BF_X(k))*X3
       BTY= (BTY+EL%BF_Y(k))*X3
       ETX= (ETX+EL%E_X(k))*X3
       ETY= (ETY+EL%E_Y(k))*X3
       phit= (phit+EL%phi(k))*X3
       VMt= (VMt+EL%VM(k))*X3
    enddo
    k=k+1
    !    b%i(k)=0
    !    b%j(k)=0
    BX= BX+BTX+EL%BF_X(k)  !+X3
    BY= BY+BTY+EL%BF_Y(k)  !+X3
    EX= EX+ETX+EL%E_X(k)  !+X3
    EY= EY+ETY+EL%E_Y(k)  !+X3
    phi= phi+phit+EL%phi(k)  !+X3
    VM= VM+VMt+EL%VM(k)  !+X3

!    if(kic) then
!     B(1)=BX 
!     B(2)=BY 
!     B(3)=0.0_dp
!    else
!     B(1)=BY/(1.0_dp+EL%P%B0*X(1))
!     B(2)=-BX/(1.0_dp+EL%P%B0*X(1))
!     B(3)=0.0_dp
!    endif

    if(kic) then
     if(EL%P%exact) then
      B(1)=-BY*(1.0_dp+EL%P%B0*X(1))
      B(2)=BX*(1.0_dp+EL%P%B0*X(1))
    else
      B(1)=-BY-el%bn(1)*EL%P%B0*X(1)  
      B(2)=BX 
    endif
     B(3)=0.0_dp
    else
     B(1)=BX
     B(2)=BY
     B(3)=0.0_dp
    endif

    E(1)=Ex*volt_c/EL%P%P0C
    E(2)=Ey*volt_c/EL%P%P0C
    E(3)=0.0_dp
    phi=phi*volt_c/EL%P%P0C

    CALL KILL(X1,X3,BX,BY,BTX,BTY,BtYT)
    CALL KILL(phit,EX,ETX,EY,ETY,VMT)
  END SUBROUTINE GETELECTRICP

!  SUBROUTINE GETMULB_TEAPOTR(EL,B,VM,X,kick)
!    IMPLICIT NONE
!    real(dp),INTENT(INOUT):: X(6),B(3),VM
!    TYPE(TEAPOT),INTENT(IN):: EL
!    real(dp) X1,X3,BX,BY,BTX,BTY,BtYT,VMt
!    INTEGER J,M,A,K
!    logical(lp),optional:: kick
!    logical(lp) kic
!
!    kic=my_false
!    if(present(kick)) kic=kick
!    X1=X(1)
!    X3=X(3)
!
!    BX=0.0_dp
!    BY=0.0_dp
!    VM=0.0_dp
!
!    k=0
!    m=EL%P%nmul !-1
!    do a=m,1,-1
!       BTX=0.0_dp
!       BTY=0.0_dp
!       VMT=0.0_dp
!       do j=m-a,1,-1
!          k=k+1
!          !b%i(k)=a
!          !b%j(k)=j
!          BTX= (BTX+EL%BF_X(k))*X3  !x1
!          BTY= (BTY+EL%BF_Y(k))*X3
!          VMT= (VMT+EL%VM(k))*X3
!       enddo
!
!       k=k+1
! 
!       BTX= (BTX+EL%BF_X(k))
!       BTY= (BTY+EL%BF_Y(k))
!       VMT= (VMT+EL%VM(k))
!       BX= (BX+BTX)*X1
!       BY= (BY+BTY)*X1
!       VM= (VM+VMT)*X1
!
!    enddo
!    BTX=0.0_dp
!    BTY=0.0_dp
!    VMT=0.0_dp
!    do j=m,1,-1
!       k=k+1
!       BTX= (BTX+EL%BF_X(k))*X3
!       BTY= (BTY+EL%BF_Y(k))*X3
!       VMT= (VMT+EL%VM(k))*X3
!    enddo
!    k=k+1
! 
!    BX= BX+BTX+EL%BF_X(k)  !+X3
!    BY= BY+BTY+EL%BF_Y(k)  !+X3
!    VM= VM+VMT+EL%VM(k)  !+X3
!
!
!    if(kic) then
!     B(1)=-BY*(1.0_dp+EL%P%B0*X(1))
!     B(2)=BX*(1.0_dp+EL%P%B0*X(1))
!     B(3)=0.0_dp
!    else
!     B(1)=BX
!     B(2)=BY
!     B(3)=0.0_dp
!    endif
!
!  END SUBROUTINE GETMULB_TEAPOTR
!
!  SUBROUTINE GETMULB_TEAPOTP(EL,B,VM,X,kick)
!    IMPLICIT NONE
!    TYPE(REAL_8),INTENT(INOUT):: X(6),B(3),VM
!    TYPE(TEAPOTP),INTENT(IN):: EL
!    TYPE(REAL_8) X1,X3,BX,BY,BTX,BTY,BtYT,VMT
!    INTEGER J,M,A,K
!    logical(lp),optional:: kick
!    logical(lp) kic
!
!    kic=my_false
!    if(present(kick)) kic=kick
!
!    CALL ALLOC(X1,X3,BX,BY,BTX,BTY,BtYT,VMT)
!
!    X1=X(1)
!    X3=X(3)
!
!    BX=0.0_dp
!    BY=0.0_dp
!    VM=0.0_dp
!
!    k=0
!    m=EL%P%nmul !-1
!    do a=m,1,-1
!       BTX=0.0_dp
!       BTY=0.0_dp
!       VMT=0.0_dp
!       do j=m-a,1,-1
!          k=k+1
!          BTX= (BTX+EL%BF_X(k))*X3  !x1
!          BTY= (BTY+EL%BF_Y(k))*X3
!          VMT= (VMT+EL%VM(k))*X3
!       enddo
!       k=k+1
!       BTX= (BTX+EL%BF_X(k))
!       BTY= (BTY+EL%BF_Y(k))
!       VMT= (VMT+EL%VM(k))
!       BX= (BX+BTX)*X1
!       BY= (BY+BTY)*X1
!       VM= (VM+VMT)*X1
!    enddo
!    BTX=0.0_dp
!    BTY=0.0_dp
!    VMT=0.0_dp
!    do j=m,1,-1
!       k=k+1
!       BTX= (BTX+EL%BF_X(k))*X3
!       BTY= (BTY+EL%BF_Y(k))*X3
!       VMT= (VMT+EL%VM(k))*X3
!    enddo
!    k=k+1
!    BX= BX+BTX+EL%BF_X(k)  !+X3
!    BY= BY+BTY+EL%BF_Y(k)  !+X3
!    VM= VM+VMT+EL%VM(k)  !+X3

!    if(kic) then
!     B(1)=-BY*(1.0_dp+EL%P%B0*X(1))
!     B(2)=BX*(1.0_dp+EL%P%B0*X(1))
!     B(3)=0.0_dp
!    else
!     B(1)=BX
!     B(2)=BY
!     B(3)=0.0_dp
!    endif
!
!
!    CALL KILL(X1,X3,BX,BY,BTX,BTY,BtYT,VMT)
!
!  END SUBROUTINE GETMULB_TEAPOTP


  ! cav_trav

  subroutine feval_teapotr(X,k,f,EL)   !electric teapot s
    IMPLICIT NONE
    real(dp), INTENT(INout) :: X(6)
    real(dp), INTENT(INOUT) :: F(6)
    REAL(DP) PZ,DEL,H,B(3),E(3),dir,VM
    TYPE(teapot),  INTENT(IN) :: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
 
     call GETELECTRIC(EL,E,DEL,B,VM,X,kick=my_true)
     e(3)=del
     DIR=EL%P%DIR*EL%P%CHARGE

     IF(EL%P%EXACT) THEN
        if(k%TIME) then
           H=1.0_dp+EL%P%B0*X(1)
           DEL=x(5)-E(3)*EL%P%CHARGE
           PZ=ROOT(1.0_dp+2*del/EL%P%BETA0+del**2-x(2)**2-x(4)**2)
           F(1)=X(2)*H/PZ
           F(3)=X(4)*H/PZ
           F(2)=EL%P%B0*PZ+dir*B(1)+H*(1.0_dp/EL%P%BETA0+del)/pz*E(1)*EL%P%CHARGE
           F(4)=dir*B(2)+H*(1.0_dp/EL%P%BETA0+del)/pz*E(2)*EL%P%CHARGE 
           F(5)=0.0_dp
           F(6)=H*(1.0_dp/EL%P%BETA0+del)/PZ+(k%TOTALPATH-1)/EL%P%BETA0  !! ld=L in sector bend
        else
           H=1.0_dp+EL%P%B0*X(1)
           DEL=x(5)-E(3)*EL%P%CHARGE
           PZ=ROOT(1.0_dp+2*del+del**2-x(2)**2-x(4)**2)
           F(1)=X(2)*H/PZ
           F(3)=X(4)*H/PZ
           F(2)=EL%P%B0*PZ+dir*B(1)+H*(1.0_dp+del)/pz*E(1)*EL%P%CHARGE
           F(4)=dir*B(2)+H*(1.0_dp+del)/pz*E(2)*EL%P%CHARGE 
           F(5)=0.0_dp
           F(6)=H*(1.0_dp+del)/PZ+(k%TOTALPATH-1) 
        endif
     ELSE
        if(k%TIME) then
           DEL=x(5)-E(3)*EL%P%CHARGE
           PZ=ROOT(1.0_dp+2*del/EL%P%BETA0+del**2)
           F(1)=X(2)/PZ
           F(3)=X(4)/PZ
           F(2)=EL%P%B0*(1.0_dp+x(5)/EL%P%BETA0)+dir*B(1)+(1.0_dp/EL%P%BETA0+del)/pz*E(1)*EL%P%CHARGE* &
            (1.0_dp+0.5_dp*(x(2)**2+x(4)**2)/pz**2)
           F(4)=dir*B(2)+(1.0_dp/EL%P%BETA0+del)/pz*E(2)*EL%P%CHARGE*(1.0_dp+0.5_dp*(x(2)**2+x(4)**2)/pz**2)
           F(5)=0.0_dp
           F(6)=(1.0_dp/EL%P%BETA0+del)/PZ*(1.0_dp+0.5_dp*(x(2)**2+x(4)**2)/pz**2)+(k%TOTALPATH-1)/EL%P%BETA0 &
           +EL%P%B0*x(1)/EL%P%BETA0  !! ld=L in sector bend
        else
           DEL=x(5)-E(3)*EL%P%CHARGE
           PZ=1.0_dp+del
           F(1)=X(2)/PZ
           F(3)=X(4)/PZ
           F(2)=EL%P%B0*(1.0_dp+x(5))+dir*B(1)+(1.0_dp+del)/pz*E(1)*EL%P%CHARGE*(1.0_dp+0.5_dp*(x(2)**2+x(4)**2)/pz**2)
           F(4)=dir*B(2)+(1.0_dp+del)/pz*E(2)*EL%P%CHARGE*(1.0_dp+0.5_dp*(x(2)**2+x(4)**2)/pz**2)
           F(5)=0.0_dp
           F(6)=(1.0_dp+del)/PZ*(1.0_dp+0.5_dp*(x(2)**2+x(4)**2)/pz**2)+(k%TOTALPATH-1)+EL%P%B0*x(1)   !! ld=L in sector bend
        endif
     ENDIF
     
   END subroutine feval_teapotr
 
  subroutine feval_teapotp(X,k,f,EL)   ! MODELLED BASED ON DRIFT
    IMPLICIT NONE
    type(real_8), INTENT(INout) :: X(6)
    type(real_8),  INTENT(INOUT) :: F(6)
    type(real_8) PZ,DEL,H,B(3),E(3),VM
    TYPE(teapotp),  INTENT(IN) :: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir 

     call alloc(PZ,DEL,H,B(1),B(2),B(3),VM)
      call alloc(E,3)

     DIR=EL%P%DIR*EL%P%CHARGE
     call GETELECTRIC(EL,E,del,B,VM,X,kick=my_true)
     E(3)=del

     IF(EL%P%EXACT) THEN
        if(k%TIME) then
           H=1.0_dp+EL%P%B0*X(1)
           DEL=x(5)-E(3)*EL%P%CHARGE
           PZ=sqrt(1.0_dp+2*del/EL%P%BETA0+del**2-x(2)**2-x(4)**2)
           F(1)=X(2)*H/PZ
           F(3)=X(4)*H/PZ
           F(2)=EL%P%B0*PZ+dir*B(1)+H*(1.0_dp/EL%P%BETA0+del)/pz*E(1)*EL%P%CHARGE
           F(4)=dir*B(2)+H*(1.0_dp/EL%P%BETA0+del)/pz*E(2)*EL%P%CHARGE
           F(5)=0.0_dp
           F(6)=H*(1.0_dp/EL%P%BETA0+del)/PZ+(k%TOTALPATH-1)/EL%P%BETA0  !! ld=L in sector bend
        else
           H=1.0_dp+EL%P%B0*X(1)
           DEL=x(5)-E(3)*EL%P%CHARGE
           PZ=sqrt(1.0_dp+2*del+del**2-x(2)**2-x(4)**2)
           F(1)=X(2)*H/PZ
           F(3)=X(4)*H/PZ
           F(2)=EL%P%B0*PZ+dir*B(1)+H*(1.0_dp+del)/pz*E(1)*EL%P%CHARGE
           F(4)=dir*B(2)+H*(1.0_dp+del)/pz*E(2)*EL%P%CHARGE 
           F(5)=0.0_dp
           F(6)=H*(1.0_dp+del)/PZ+(k%TOTALPATH-1) 
        endif
     ELSE
        if(k%TIME) then
           DEL=x(5)-E(3)*EL%P%CHARGE
           PZ=sqrt(1.0_dp+2*del/EL%P%BETA0+del**2)
           F(1)=X(2)/PZ
           F(3)=X(4)/PZ
           F(2)=EL%P%B0*(1.0_dp+x(5)/EL%P%BETA0)+dir*B(1)+(1.0_dp/EL%P%BETA0+del)/pz*E(1)*EL%P%CHARGE*  &
            (1.0_dp+0.5_dp*(x(2)**2+x(4)**2)/pz**2)
           F(4)=dir*B(2)+(1.0_dp/EL%P%BETA0+del)/pz*E(2)*EL%P%CHARGE*(1.0_dp+0.5_dp*(x(2)**2+x(4)**2)/pz**2)
           F(5)=0.0_dp
           F(6)=(1.0_dp/EL%P%BETA0+del)/PZ*(1.0_dp+0.5_dp*(x(2)**2+x(4)**2)/pz**2)+ &
            (k%TOTALPATH-1)/EL%P%BETA0+EL%P%B0*x(1)/EL%P%BETA0  !! ld=L in sector bend
        else
           DEL=x(5)-E(3)*EL%P%CHARGE
           PZ=1.0_dp+del
           F(1)=X(2)/PZ
           F(3)=X(4)/PZ
           F(2)=EL%P%B0*(1.0_dp+x(5))+dir*B(1)+(1.0_dp+del)/pz*E(1)*EL%P%CHARGE*(1.0_dp+0.5_dp*(x(2)**2+x(4)**2)/pz**2)
           F(4)=dir*B(2)+(1.0_dp+del)/pz*E(2)*EL%P%CHARGE*(1.0_dp+0.5_dp*(x(2)**2+x(4)**2)/pz**2)
           F(5)=0.0_dp
           F(6)=(1.0_dp+del)/PZ*(1.0_dp+0.5_dp*(x(2)**2+x(4)**2)/pz**2)+(k%TOTALPATH-1)+EL%P%B0*x(1)   !! ld=L in sector bend
        endif
     ENDIF
     call KILL(PZ,DEL,H,B(1),B(2),B(3),VM)
     call KILL(E,3)

   END subroutine feval_teapotp
 
   subroutine rk2_teapotr(h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    real(dp), INTENT(INOUT)::  y(ne)
    real(dp)  yt(ne),f(ne),a(ne),b(ne)
    type (teapot) ,INTENT(IN)::  GR
    integer j
    real(dp), intent(inout) :: h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    call feval_teapot(y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+b(j)
    enddo

    return
  end  subroutine rk2_teapotr

  ! 2 order Runge
  subroutine rk2_teapotp(h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    type (real_8), INTENT(INOUT)::  y(ne)
    type (real_8)  yt(ne),f(ne),a(ne),b(ne)
    type (teapotp) ,INTENT(IN)::  GR
    integer j
    type(real_8), intent(inout) :: h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    call alloc(yt,ne)
    call alloc(f,ne)
    call alloc(a,ne)
    call alloc(b,ne)


    call feval_teapot(y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+b(j)
    enddo

    call kill(yt,ne)
    call kill(f,ne)
    call kill(a,ne)
    call kill(b,ne)

    return
  end  subroutine rk2_teapotp

  subroutine rk4_teapotr(h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    real(dp), INTENT(INOUT)::  y(ne)
    real(dp)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne)
    type (teapot) ,INTENT(IN)::  GR
    integer j
    real(dp), intent(inout) :: h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    call feval_teapot(y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + b(j)/2.0_dp
    enddo


    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+c(j)
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo


    do  j=1,ne
       y(j) = y(j)+(a(j)+2.0_dp*b(j)+2.0_dp*c(j)+d(j))/6.0_dp
    enddo

    return
  end  subroutine rk4_teapotr

  subroutine rk4_teapotp(h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    type(real_8), INTENT(INOUT)::  y(ne)
    type (teapotp) ,INTENT(IN)::  GR
    type(real_8), intent(inout) :: h
    type(real_8)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne)
    integer j
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    call alloc(yt)
    call alloc(f)
    call alloc(a)
    call alloc(b)
    call alloc(c)
    call alloc(d)

    call feval_teapot(y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + b(j)/2.0_dp
    enddo


    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+c(j)
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo


    do  j=1,ne
       y(j) = y(j)+(a(j)+2.0_dp*b(j)+2.0_dp*c(j)+d(j))/6.0_dp
    enddo

    call kill(yt)
    call kill(f)
    call kill(a)
    call kill(b)
    call kill(c)
    call kill(d)

    return
  end  subroutine rk4_teapotp

  subroutine rk6_teapotr(h,GR,y,k)
    IMPLICIT none
    !  Written by Rob Ryne, Spring 1986, based on a routine of
    !c  J. Milutinovic.
    !c  For a reference, see page 76 of F. Ceschino and J Kuntzmann,
    !c  Numerical Solution of Initial Value Problems, Prentice Hall 1966.
    !c  This integration routine makes local truncation errors at each
    !c  step of order h**7.
    !c  That is, it is locally correct through terms of order h**6.
    !c  Each step requires 8 function evaluations.

    integer ne
    parameter (ne=6)
    real(dp), INTENT(INOUT)::  y(ne)
    real(dp)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne),e(ne),g(ne),o(ne),p(ne)
    type (teapot) ,INTENT(IN)::  GR
    integer j
    real(dp), intent(inout) :: h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    call feval_teapot(y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/9.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + (a(j) + 3.0_dp*b(j))/24.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j)+(a(j)-3.0_dp*b(j)+4.0_dp*c(j))/6.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j) + (-5.0_dp*a(j) + 27.0_dp*b(j) - 24.0_dp*c(j) + 6.0_dp*d(j))/8.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       e(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j) + (221.0_dp*a(j) - 981.0_dp*b(j) + 867.0_dp*c(j)- 102.0_dp*d(j) + e(j))/9.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do   j=1,ne
       g(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j) = y(j)+(-183.0_dp*a(j)+678.0_dp*b(j)-472.0_dp*c(j)-66.0_dp*d(j)+80.0_dp*e(j) + 3.0_dp*g(j))/48.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       o(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j) = y(j)+(716.0_dp*a(j)-2079.0_dp*b(j)+1002.0_dp*c(j)+834.0_dp*d(j)-454.0_dp*e(j)-9.0_dp*g(j)+72.0_dp*o(j))/82.0_dp
    enddo


    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       p(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+(41.0_dp*a(j)+216.0_dp*c(j)+27.0_dp*d(j)+272.0_dp*e(j)+27.0_dp*g(j)+216.0_dp*o(j)+41.0_dp*p(j))/840.0_dp
    enddo


    return
  end  subroutine rk6_teapotr



  ! sixth order Runge
  subroutine rk6_teapotp(h,GR,y,k)
    IMPLICIT none


    integer ne
    parameter (ne=6)
    type (real_8), INTENT(INOUT)::  y(ne)
    type (real_8)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne),e(ne),g(ne),o(ne),p(ne)
    type (teapotp) ,INTENT(IN)::  GR
    integer j
    type(real_8), intent(inout) :: h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    call alloc(yt,ne)
    call alloc(f,ne)
    call alloc(a,ne)
    call alloc(b,ne)
    call alloc(c,ne)
    call alloc(d,ne)
    call alloc(e,ne)
    call alloc(g,ne)
    call alloc(o,ne)
    call alloc(p,ne)

    call feval_teapot(y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/9.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + (a(j) + 3.0_dp*b(j))/24.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j)+(a(j)-3.0_dp*b(j)+4.0_dp*c(j))/6.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j) + (-5.0_dp*a(j) + 27.0_dp*b(j) - 24.0_dp*c(j) + 6.0_dp*d(j))/8.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       e(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j) + (221.0_dp*a(j) - 981.0_dp*b(j) + 867.0_dp*c(j)- 102.0_dp*d(j) + e(j))/9.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do   j=1,ne
       g(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j) = y(j)+(-183.0_dp*a(j)+678.0_dp*b(j)-472.0_dp*c(j)-66.0_dp*d(j)+80.0_dp*e(j) + 3.0_dp*g(j))/48.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       o(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j) = y(j)+(716.0_dp*a(j)-2079.0_dp*b(j)+1002.0_dp*c(j)+834.0_dp*d(j)-454.0_dp*e(j)-9.0_dp*g(j)+72.0_dp*o(j))/82.0_dp
    enddo


    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       p(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+(41.0_dp*a(j)+216.0_dp*c(j)+27.0_dp*d(j)+272.0_dp*e(j)+27.0_dp*g(j)+216.0_dp*o(j)+41.0_dp*p(j))/840.0_dp
    enddo

    call kill(yt,ne)
    call kill(f,ne)
    call kill(a,ne)
    call kill(b,ne)
    call kill(c,ne)
    call kill(d,ne)
    call kill(e,ne)
    call kill(g,ne)
    call kill(o,ne)
    call kill(p,ne)

    return
  end  subroutine rk6_teapotp
 
   SUBROUTINE SSECH1R(EL,YL,DL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN):: YL,DL
    TYPE(TEAPOT),INTENT(IN):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    ! if(abs(x(1))+abs(x(3))+abs(x(2))+abs(x(4))>absolute_aperture.or.(.not.CHECK_MADX_APERTURE)) then
    !    if(CHECK_MADX_APERTURE) c_%message="exceed absolute_aperture in SSECH1R"
    !    CHECK_STABLE=.false.
    ! endif
    ! if(.not.CHECK_STABLE) return

    IF(EL%DRIFTKICK) THEN
       CALL Sprot(EL,YL,DL,X,k)
    ELSE
       CALL SSEC(EL,YL,DL,X,k)
    ENDIF

  END SUBROUTINE SSECH1R

  SUBROUTINE SSECH1P(EL,YL,DL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN):: YL
    real(dp),INTENT(IN):: DL
    TYPE(TEAPOTP),INTENT(IN):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(EL%DRIFTKICK) THEN
       CALL Sprot(EL,YL,DL,X,k)
    ELSE
       CALL SSEC(EL,YL,DL,X,k)
    ENDIF

  END SUBROUTINE SSECH1P

  SUBROUTINE Sprotr(EL,YL,DL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN):: YL,DL
    TYPE(TEAPOT),INTENT(IN):: EL
    real(dp) XN(6),PZ,PT
    real(dp)  A,b,R
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    if(EL%P%B0/=0.0_dp) then
       A=YL*EL%P%B0
       R=1.0_dp/EL%P%B0
       if(k%TIME) then
          B=EL%P%BETA0
          PZ=ROOT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(2)**2-X(4)**2)
          PT=1.0_dp-X(2)*TAN(A)/PZ
          !       XN(1)=(X(1)+R)/COS(A)/PT-R
          XN(1)=(X(1)+R*(2.0_dp*sin(a/2.0_dp)**2+X(2)*sin(A)/PZ))/COS(A)/PT
          XN(2)=X(2)*COS(A)+SIN(A)*PZ
          XN(3)=X(3)+X(4)*(X(1)+R)*TAN(A)/PZ/PT
          XN(6)=X(6)+(X(1)+R)*TAN(A)/PZ/PT*(1.0_dp/b+x(5))
          XN(6)=XN(6)+(k%TOTALPATH-1)*DL/EL%P%BETA0
       else
          PZ=ROOT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          PT=1.0_dp-X(2)*TAN(A)/PZ
          XN(1)=(X(1)+R*(2.0_dp*sin(a/2.0_dp)**2+X(2)*sin(A)/PZ))/COS(A)/PT
          XN(2)=X(2)*COS(A)+SIN(A)*PZ
          XN(3)=X(3)+X(4)*(X(1)+R)*TAN(A)/PZ/PT
          XN(6)=X(6)+(1.0_dp+X(5))*(X(1)+R)*TAN(A)/PZ/PT
          XN(6)=XN(6)+(k%TOTALPATH-1)*DL
       endif
       X(1)=XN(1)
       X(2)=XN(2)
       X(3)=XN(3)
       X(6)=XN(6)
    else
       CALL DRIFT(YL,DL,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    endif
    !    CALL CHECK_STABILITY(X)
    call check_root_drift(el%p,X,k)
  END SUBROUTINE Sprotr

  SUBROUTINE SPROTP(EL,YL,DL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN):: YL
    real(dp),INTENT(IN):: DL
    TYPE(TEAPOTP),INTENT(IN):: EL
    TYPE(REAL_8) XN(6),PZ,PT,A,ah
    real(dp)  b,R
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    if(EL%P%B0/=0.0_dp) then
       CALL ALLOC( XN,6)
       CALL ALLOC( PZ)
       CALL ALLOC( PT)
       CALL ALLOC( A,ah)
       A=YL*EL%P%B0
       ah=a/2.0_dp
       R=1.0_dp/EL%P%B0
       if(k%TIME) then
          B=EL%P%BETA0
          PZ=SQRT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(2)**2-X(4)**2)
          PT=1.0_dp-X(2)*TAN(A)/PZ
          !          XN(1)=(X(1)+R)/COS(A)/PT-R
          XN(1)=(X(1)+R*(2.0_dp*sin(ah)**2+X(2)*sin(A)/PZ))/COS(A)/PT
          XN(2)=X(2)*COS(A)+SIN(A)*PZ
          XN(3)=X(3)+X(4)*(X(1)+R)*TAN(A)/PZ/PT
          XN(6)=X(6)+(X(1)+R)*TAN(A)/PZ/PT*(1.0_dp/b+x(5))
          XN(6)=XN(6)+(k%TOTALPATH-1)*DL/EL%P%BETA0
       else
          PZ=SQRT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          PT=1.0_dp-X(2)*TAN(A)/PZ
          XN(1)=(X(1)+R*(2.0_dp*sin(ah)**2+X(2)*sin(A)/PZ))/COS(A)/PT
          XN(2)=X(2)*COS(A)+SIN(A)*PZ
          XN(3)=X(3)+X(4)*(X(1)+R)*TAN(A)/PZ/PT
          XN(6)=X(6)+(1.0_dp+X(5))*(X(1)+R)*TAN(A)/PZ/PT
          XN(6)=XN(6)+(k%TOTALPATH-1)*DL
       endif
       X(1)=XN(1)
       X(2)=XN(2)
       X(3)=XN(3)
       X(6)=XN(6)

       CALL KILL( XN,6)
       CALL KILL( PZ)
       CALL KILL( PT)
       CALL KILL( A,ah)
    else
       CALL DRIFT(YL,DL,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    endif
  END SUBROUTINE SPROTP

  SUBROUTINE Ssecr(EL,YL,DL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN):: YL,DL
    TYPE(TEAPOT),INTENT(IN):: EL
    real(dp) XN(6),PZ,PZS,DPX,PT
    real(dp)  A,b,R
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    DIR=EL%P%DIR*EL%P%CHARGE

    A=YL*EL%P%B0
    R=1.0_dp/EL%P%B0
    if(k%TIME) then
       B=EL%P%BETA0
       PZ=ROOT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(2)**2-X(4)**2)
       XN(2)=X(2)*COS(A)+(PZ-DIR*EL%BN(1)*(R+X(1)))*SIN(A)
       DPX=(-X(2)*SIN(A)+(PZ-DIR*EL%BN(1)*(R+X(1)))*COS(A))/DIR/EL%BN(1)  !DPX*R/B1
       PT=ROOT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(4)**2)
       PZS=ROOT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-XN(2)**2-X(4)**2)
       XN(1)=PZS/DIR/EL%BN(1)-DPX-R

       XN(3)=(A+ARCSIN(X(2)/PT)-ARCSIN(XN(2)/PT))/DIR/EL%BN(1)

       XN(6)=X(6)+XN(3)*(1.0_dp/b+x(5))
       XN(6)=XN(6)+(k%TOTALPATH-1)*DL/EL%P%BETA0

       XN(3)=X(3)+X(4)*XN(3)
    else
       PZ=ROOT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
       XN(2)=X(2)*COS(A) + ( PZ-DIR*EL%BN(1)*(R+X(1)) ) *SIN(A)
       DPX=(-X(2)*SIN(A)+(PZ-DIR*EL%BN(1)*(R+X(1)))*COS(A))/DIR/EL%BN(1)  !DPX*R/B1
       PT=ROOT((1.0_dp+X(5))**2-X(4)**2)
       PZS=ROOT((1.0_dp+X(5))**2-XN(2)**2-X(4)**2)
       XN(1)=PZS/DIR/EL%BN(1)-DPX-R

       XN(3)=(A+ARCSIN(X(2)/PT)-ARCSIN(XN(2)/PT))/DIR/EL%BN(1)

       XN(6)=X(6)+XN(3)*(1.0_dp+X(5))
       XN(6)=XN(6)+(k%TOTALPATH-1)*DL
       XN(3)=X(3)+X(4)*XN(3)

    endif
    X(1)=XN(1)
    X(2)=XN(2)
    X(3)=XN(3)
    X(6)=XN(6)
    !    CALL CHECK_STABILITY(X)
    call check_root_drift(EL%P,X,k)
  END SUBROUTINE Ssecr


  SUBROUTINE SsecP(EL,YL,DL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN):: YL
    real(dp),INTENT(IN):: DL
    TYPE(TEAPOTP),INTENT(IN):: EL
    TYPE(REAL_8) XN(6),PZ,PT,A,PZS,DPX
    real(dp)  b,R
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    DIR=EL%P%DIR*EL%P%CHARGE



    CALL ALLOC( XN,6)
    CALL ALLOC( PZ,PT,A,PZS,DPX)
    A=YL*EL%P%B0
    R=1.0_dp/EL%P%B0
    if(k%TIME) then
       B=EL%P%BETA0
       PZ=SQRT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(2)**2-X(4)**2)
       XN(2)=X(2)*COS(A)+(PZ-DIR*EL%BN(1)*(R+X(1)))*SIN(A)
       DPX=(-X(2)*SIN(A)+(PZ-DIR*EL%BN(1)*(R+X(1)))*COS(A))/DIR/EL%BN(1)  !DPX*R/B1
       PT=SQRT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(4)**2)
       PZS=SQRT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-XN(2)**2-X(4)**2)
       XN(1)=PZS/DIR/EL%BN(1)-DPX-R

       XN(3)=(A+ASIN(X(2)/PT)-ASIN(XN(2)/PT))/DIR/EL%BN(1)

       XN(6)=X(6)+XN(3)*(1.0_dp/b+x(5))
       XN(6)=XN(6)+(k%TOTALPATH-1)*DL/EL%P%BETA0

       XN(3)=X(3)+X(4)*XN(3)
    else
       PZ=SQRT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
       XN(2)=X(2)*COS(A) + ( PZ-DIR*EL%BN(1)*(R+X(1)) ) *SIN(A)
       DPX=(-X(2)*SIN(A)+(PZ-DIR*EL%BN(1)*(R+X(1)))*COS(A))/DIR/EL%BN(1)  !DPX*R/B1
       PT=SQRT((1.0_dp+X(5))**2-X(4)**2)
       PZS=SQRT((1.0_dp+X(5))**2-XN(2)**2-X(4)**2)
       XN(1)=PZS/DIR/EL%BN(1)-DPX-R

       XN(3)=(A+ASIN(X(2)/PT)-ASIN(XN(2)/PT))/DIR/EL%BN(1)

       XN(6)=X(6)+XN(3)*(1.0_dp+X(5))
       XN(6)=XN(6)+(k%TOTALPATH-1)*DL
       XN(3)=X(3)+X(4)*XN(3)

    endif
    X(1)=XN(1)
    X(2)=XN(2)
    X(3)=XN(3)
    X(6)=XN(6)

    CALL KILL( XN,6)
    CALL KILL( PZ,PT,A,PZS,DPX)
  END SUBROUTINE SsecP

  SUBROUTINE SKICKR(EL,YL,X,k)
    IMPLICIT NONE 
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN):: YL
    TYPE(TEAPOT),INTENT(IN):: EL
    real(dp) b(3),VM,e(3),phi
 
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    !    if(abs(x(1))+abs(x(3))+abs(x(2))+abs(x(4))>absolute_aperture.or.(.not.CHECK_MADX_APERTURE)) then
    !       if(CHECK_MADX_APERTURE) c_%message="exceed absolute_aperture in SKICKR"
    !       CHECK_STABLE=.false.
    !    endif
    !    if(.not.CHECK_STABLE) return

    DIR=EL%P%DIR*EL%P%CHARGE

!    call GETMULB_TEAPOT(EL,B,VM,X,kick=my_true)
    call GETELECTRIC(EL,E,phi,B,VM,X,kick=my_true)

    X(2)=X(2)+YL*DIR*B(1)
    X(4)=X(4)+YL*DIR*B(2)
    IF(.NOT.EL%DRIFTKICK) THEN
       X(2)=X(2)+YL*DIR*EL%BN(1)*(1.0_dp+X(1)*EL%P%B0)
    ENDIF

  END SUBROUTINE SKICKR


  SUBROUTINE SKICKP(EL,YL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN):: YL
    TYPE(TEAPOTP),INTENT(IN):: EL
    TYPE(REAL_8) B(3),VM,e(3),phi
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    CALL ALLOC(B,3)
    CALL ALLOC(VM)
    CALL ALLOC(E,3)
    CALL ALLOC(phi)
    DIR=EL%P%DIR*EL%P%CHARGE

   !call GETMULB_TEAPOT(EL,B,VM,X,kick=my_true)
    call GETELECTRIC(EL,E,phi,B,VM,X,kick=my_true)
 

 
    X(2)=X(2)+YL*DIR*B(1)
    X(4)=X(4)+YL*DIR*B(2)

    IF(.NOT.EL%DRIFTKICK) THEN
       X(2)=X(2)+YL*DIR*EL%BN(1)*(1.0_dp+X(1)*EL%P%B0)
    ENDIF

 
    CALL KILL(B,3)
    CALL KILL(VM)
    CALL KILL(E,3)
    CALL KILL(phi)

  END SUBROUTINE SKICKP

  SUBROUTINE INTER_TEAPOT(EL,X,k,pos)
    IMPLICIT NONE
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(TEAPOT),INTENT(IN):: EL
    real(dp) D,DH,DD
    real(dp) D1,D2,DK1,DK2
    real(dp) DD1,DD2
    real(dp) DF(4),DK(4),DDF(4)
    INTEGER I,J,f1
    integer,optional :: pos
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    if(.not.el%electric) then

    SELECT CASE(EL%P%METHOD)
    CASE(1)
       if(EL%F==1) then
          f1=0
       else
          f1=EL%F+1
       endif
       DH=EL%L/EL%P%NST
       D=EL%L/(EL%P%NST/EL%F/2)
       DD=EL%P%LD/EL%P%NST

       IF(MOD(POS,2*EL%F)==f1) THEN
          CALL SKICK (EL,D,X,k)
       ENDIF
       CALL SSECH1(EL,DH,DD,X,k)
    CASE(2)
       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       DD=EL%P%LD/2.0_dp/EL%P%NST

       CALL SSECH1(EL,DH,DD,X,k)
       CALL SKICK(EL,D,X,k)
       CALL SSECH1(EL,DH,DD,X,k)
    CASE(4)
       D1=EL%L*FD1/EL%P%NST
       D2=EL%L*FD2/EL%P%NST
       DD1=EL%P%LD*FD1/EL%P%NST
       DD2=EL%P%LD*FD2/EL%P%NST
       DK1=EL%L*FK1/EL%P%NST
       DK2=EL%L*FK2/EL%P%NST

       CALL SSECH1(EL,D1,DD1,X,k)
       CALL SKICK (EL,DK1,X,k)
       CALL SSECH1(EL,D2,DD2,X,k)
       CALL SKICK (EL,DK2,X,k)

       CALL SSECH1(EL,D2,DD2,X,k)
       CALL SKICK (EL,DK1,X,k)
       CALL SSECH1(EL,D1,DD1,X,k)



    CASE(6)
       DO I =1,4
          DF(I)=EL%L*YOSD(I)/EL%P%NST
          DDF(I)=EL%P%LD*YOSD(I)/EL%P%NST
          DK(I)=EL%L*YOSK(I)/EL%P%NST
       ENDDO

       DO J=4,2,-1
          CALL SSECH1(EL,DF(J),DDF(J),X,k)
          CALL SKICK (EL,DK(J),X,k)
       ENDDO
       CALL SSECH1(EL,DF(1),DDF(1),X,k)
       CALL SKICK (EL,DK(1),X,k)

       CALL SSECH1(EL,DF(1),DDF(1),X,k)
       DO J=2,4
          CALL SKICK (EL,DK(J),X,k)
          CALL SSECH1(EL,DF(J),DDF(J),X,k)
       ENDDO



    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

    else
    SELECT CASE(EL%P%METHOD)

    CASE(2)

       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       DD=EL%P%LD/2.0_dp/EL%P%NST

       call rk2_teapot(d,el,x,k)

    CASE(4)
       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       DD=EL%P%LD/2.0_dp/EL%P%NST

       call rk4_teapot(d,el,x,k)


    CASE(6)
       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       DD=EL%P%LD/2.0_dp/EL%P%NST

       call rk6_teapot(d,el,x,k)

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

    endif


  END SUBROUTINE INTER_TEAPOT

  SUBROUTINE INTEP_TEAPOT(EL,X,k,pos)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(TEAPOTP),INTENT(IN):: EL
    real(dp) DD
    real(dp) DD1,DD2
    real(dp) DDF(4)
    TYPE(REAL_8) DH,D,D1,D2,DK1,DK2,DF(4),DK(4)
    INTEGER I,J,f1
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    integer,optional :: pos

    if(.not.el%electric) then
    SELECT CASE(EL%P%METHOD)
    CASE(1)
       CALL ALLOC(DH,D)
       if(EL%F==1) then
          f1=0
       else
          f1=EL%F+1
       endif
       DH=EL%L/EL%P%NST
       D=EL%L/(EL%P%NST/EL%F/2)
       DD=EL%P%LD/EL%P%NST

       IF(MOD(POS,2*EL%F)==f1) THEN
          CALL SKICK (EL,D,X,k)
       ENDIF
       CALL SSECH1(EL,DH,DD,X,k)
       CALL kill(DH,D)
    CASE(2)

       CALL ALLOC(DH,D)

       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       DD=EL%P%LD/2.0_dp/EL%P%NST

       CALL SSECH1(EL,DH,DD,X,k)
       CALL SKICK(EL,D,X,k)
       CALL SSECH1(EL,DH,DD,X,k)

       CALL KILL(DH,D)

    CASE(4)
       CALL ALLOC(D1,D2,DK1,DK2)
       D1=EL%L*FD1/EL%P%NST
       D2=EL%L*FD2/EL%P%NST
       DD1=EL%P%LD*FD1/EL%P%NST
       DD2=EL%P%LD*FD2/EL%P%NST
       DK1=EL%L*FK1/EL%P%NST
       DK2=EL%L*FK2/EL%P%NST

       CALL SSECH1(EL,D1,DD1,X,k)
       CALL SKICK (EL,DK1,X,k)
       CALL SSECH1(EL,D2,DD2,X,k)
       CALL SKICK (EL,DK2,X,k)

       CALL SSECH1(EL,D2,DD2,X,k)
       CALL SKICK (EL,DK1,X,k)
       CALL SSECH1(EL,D1,DD1,X,k)

       CALL KILL(D1,D2,DK1,DK2)

    CASE(6)
       CALL ALLOC(DF,4);CALL ALLOC(DK,4);
       DO I =1,4
          DF(I)=EL%L*YOSD(I)/EL%P%NST
          DDF(I)=EL%P%LD*YOSD(I)/EL%P%NST
          DK(I)=EL%L*YOSK(I)/EL%P%NST
       ENDDO

       DO J=4,2,-1
          CALL SSECH1(EL,DF(J),DDF(J),X,k)
          CALL SKICK (EL,DK(J),X,k)
       ENDDO
       CALL SSECH1(EL,DF(1),DDF(1),X,k)
       CALL SKICK (EL,DK(1),X,k)

       CALL SSECH1(EL,DF(1),DDF(1),X,k)
       DO J=2,4
          CALL SKICK (EL,DK(J),X,k)
          CALL SSECH1(EL,DF(J),DDF(J),X,k)
       ENDDO

       CALL KILL(DF,4);CALL KILL(DK,4);

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

    else
    SELECT CASE(EL%P%METHOD)

    CASE(2)
       CALL ALLOC(DH,D)
       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       DD=EL%P%LD/2.0_dp/EL%P%NST

       call rk2_teapot(d,el,x,k)
       CALL kill(DH,D)
    CASE(4)
       CALL ALLOC(D1,D2,DK1,DK2)
       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       DD=EL%P%LD/2.0_dp/EL%P%NST

       call rk4_teapot(d,el,x,k)

       CALL kill(D1,D2,DK1,DK2)

    CASE(6)
       CALL ALLOC(DF,4);CALL ALLOC(DK,4);
       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       DD=EL%P%LD/2.0_dp/EL%P%NST

       call rk6_teapot(d,el,x,k)
       CALL kill(DF,4);CALL kill(DK,4);

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

    endif

  END SUBROUTINE INTEP_TEAPOT

  SUBROUTINE SINTER(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(TEAPOT),INTENT(IN):: EL
    TYPE(WORM), OPTIONAL,INTENT(INOUT):: MID
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    DO I=1,EL%P%NST
       IF(.NOT.PRESENT(MID))CALL TRACK_SLICE(EL,X,k,I)
       IF(PRESENT(MID)) CALL XMID(MID,X,I)
    ENDDO

  END SUBROUTINE SINTER

  SUBROUTINE SINTEP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(TEAPOTP),INTENT(INOUT):: EL
    INTEGER I
    logical(lp) CHECK_KNOB
    integer(2), pointer,dimension(:)::AN,BN,AE,BE
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)
    IF(EL%ELECTRIC) THEN
     CALL MAKEPOTKNOB_ELEC(EL,CHECK_KNOB,AN,BN,AE,BE)
    ELSE
     CALL MAKEPOTKNOB(EL,CHECK_KNOB,AN,BN)
    ENDIF

    DO I=1,EL%P%NST
       CALL TRACK_SLICE(EL,X,k,I)
    ENDDO

    IF(EL%ELECTRIC) THEN
         CALL UNMAKEPOTKNOB_ELEC(EL,CHECK_KNOB,AN,BN,AE,BE)
    ELSE
         CALL UNMAKEPOTKNOB(EL,CHECK_KNOB,AN,BN)
    ENDIF




  END SUBROUTINE SINTEP

  SUBROUTINE CHECKPOTKNOB(EL,CHECK_KNOB)
    IMPLICIT NONE
    TYPE(TEAPOTP),INTENT(IN):: EL
    logical(lp) CHECK_KNOB
    integer I

    CHECK_KNOB=.FALSE.
    I=1
    DO WHILE(I<=EL%P%NMUL.AND.(.NOT.CHECK_KNOB))
       IF(EL%BN(I)%KIND>=2) CHECK_KNOB=.TRUE.
       IF(EL%AN(I)%KIND>=2) CHECK_KNOB=.TRUE.
       I=I+1
    ENDDO
    IF(EL%ELECTRIC.AND.(.NOT.CHECK_KNOB)) THEN
    I=1
    DO WHILE(I<=SIZE(EL%BE).AND.(.NOT.CHECK_KNOB))
       IF(EL%BE(I)%KIND>=2) CHECK_KNOB=.TRUE.
       IF(EL%AE(I)%KIND>=2) CHECK_KNOB=.TRUE.
       I=I+1
    ENDDO
    ENDIF
    IF(EL%L%KIND==3) CHECK_KNOB=.TRUE.

  END SUBROUTINE CHECKPOTKNOB

  SUBROUTINE MAKEPOTKNOB(EL,CHECK_KNOB,AN,BN,K)
    IMPLICIT NONE
    TYPE(TEAPOTP),INTENT(INOUT):: EL
    integer(2), pointer,dimension(:)::AN,BN
    LOGICAL(LP) CHECK_KNOB,doit
    type(internal_state), optional :: k 
    integer I
    doit=.false.
    if(present(k)) then
        IF(K%PARA_IN ) doit=.TRUE.
    endif
    IF(KNOB.or.doit) THEN
       CALL CHECKPOTKNOB(EL,CHECK_KNOB) ! RECOMPUTES ONLY IF KNOB (SPEED)
       IF(CHECK_KNOB) THEN
          ALLOCATE(AN(EL%P%NMUL),BN(EL%P%NMUL))
          DO I=1,EL%P%NMUL
             BN(I)=0
             AN(I)=0
             IF(EL%BN(I)%KIND>=2) BN(I)=EL%BN(I)%KIND
             IF(EL%AN(I)%KIND>=2) AN(I)=EL%AN(I)%KIND  ! g-2 modification
          ENDDO
          if(doit.and.(.not.knob)) then
           knob=.true.
           call GETANBN(EL)
           knob=.false.
          else
           call GETANBN(EL)
          endif 
       ENDIF
    ENDIF
  END SUBROUTINE MAKEPOTKNOB

  SUBROUTINE MAKEPOTKNOB_elec(EL,CHECK_KNOB,AN,BN,AE,BE,K)
    IMPLICIT NONE
    TYPE(TEAPOTP),INTENT(INOUT):: EL
    integer(2), pointer,dimension(:)::AN,BN,AE,BE
    LOGICAL(LP) CHECK_KNOB,doit
    type(internal_state), optional :: k 
    integer I,NE
    NE=SIZE(EL%AE)
    doit=.false.
    if(present(k)) then
        IF(K%PARA_IN ) doit=.TRUE.
    endif
    IF(KNOB.or.doit) THEN
       CALL CHECKPOTKNOB(EL,CHECK_KNOB) ! RECOMPUTES ONLY IF KNOB (SPEED)
       IF(CHECK_KNOB) THEN
          ALLOCATE(AN(EL%P%NMUL),BN(EL%P%NMUL),AE(NE),BE(NE))
          DO I=1,EL%P%NMUL
             BN(I)=0
             AN(I)=0
             IF(EL%BN(I)%KIND>=2) BN(I)=EL%BN(I)%KIND
             IF(EL%AN(I)%KIND>=2) AN(I)=EL%AN(I)%KIND  ! g-2 modification
          ENDDO
          DO I=1,NE
             BE(I)=0
             AE(I)=0
             IF(EL%BE(I)%KIND>=2) BE(I)=EL%BE(I)%KIND
             IF(EL%AE(I)%KIND>=2) AE(I)=EL%AE(I)%KIND  ! g-2 modification
          ENDDO
          if(doit.and.(.not.knob)) then
           knob=.true.
           call GETAEBE(EL)
           knob=.false.
          else
           call GETAEBE(EL)
          endif 
       ENDIF
    ENDIF
  END SUBROUTINE MAKEPOTKNOB_elec


  SUBROUTINE UNMAKEPOTKNOB(EL,CHECK_KNOB,AN,BN,k)
    IMPLICIT NONE
    TYPE(TEAPOTP),INTENT(INOUT):: EL
    integer(2), pointer,dimension(:)::AN,BN
    LOGICAL(LP) CHECK_KNOB,doit
    integer I,ERROR
        type(internal_state), optional :: k 

    doit=.false.
    if(present(k)) then
        IF(K%PARA_IN ) doit=.TRUE.
    endif
    
     IF(KNOB.or.doit) THEN
       IF(CHECK_KNOB) THEN
          DO I=1,EL%P%NMUL
             EL%BN(I)%KIND=1
             EL%AN(I)%KIND=1
          ENDDO
          CALL KILL(EL)                               ! RECOMPUTES ONLY IF KNOB (SPEED)
          CALL ALLOC(EL)
          CALL GETANBN(EL)                            ! KNOB IS REMOVED THE SLOW WAY(SPEED)
          DO I=1,EL%P%NMUL
             IF(AN(I)>0) EL%AN(I)%KIND=AN(I)
             IF(BN(I)>0) EL%BN(I)%KIND=BN(I)
          ENDDO
          DEALLOCATE (AN, STAT = error)
          IF(ERROR/=0) THEN
             w_p=0
             w_p%nc=1
             w_p%fc='(1(1X,A72))'
             w_p%c(1)= " AN ARRAY not DEALLOCATED : PROBLEMS"
             ! call !write_e(357)
          ENDIF
          DEALLOCATE (BN, STAT = error)
          IF(ERROR/=0) THEN
             w_p=0
             w_p%nc=1
             w_p%fc='(1(1X,A72))'
             w_p%c(1)= " BN ARRAY not DEALLOCATED : PROBLEMS"
             ! call !write_e(357)
          ENDIF
       ENDIF
    ENDIF
  END SUBROUTINE UNMAKEPOTKNOB

  SUBROUTINE UNMAKEPOTKNOB_ELEC(EL,CHECK_KNOB,AN,BN,AE,BE,k)
    IMPLICIT NONE
    TYPE(TEAPOTP),INTENT(INOUT):: EL
    integer(2), pointer,dimension(:)::AN,BN,AE,BE
    LOGICAL(LP) CHECK_KNOB,doit
    integer I,ERROR,NE
        type(internal_state), optional :: k 
    NE=SIZE(EL%BE)
    doit=.false.
    if(present(k)) then
        IF(K%PARA_IN ) doit=.TRUE.
    endif
    
     IF(KNOB.or.doit) THEN
       IF(CHECK_KNOB) THEN
          DO I=1,EL%P%NMUL
             EL%BN(I)%KIND=1
             EL%AN(I)%KIND=1
          ENDDO
          DO I=1,NE
             EL%BE(I)%KIND=1
             EL%AE(I)%KIND=1
          ENDDO
          CALL KILL(EL)                               ! RECOMPUTES ONLY IF KNOB (SPEED)
          CALL ALLOC(EL)
          CALL GETAEBE(EL)                            ! KNOB IS REMOVED THE SLOW WAY(SPEED)
          DO I=1,EL%P%NMUL
             IF(AN(I)>0) EL%AN(I)%KIND=AN(I)
             IF(BN(I)>0) EL%BN(I)%KIND=BN(I)
          ENDDO
          DO I=1,NE
             IF(AE(I)>0) EL%AE(I)%KIND=AE(I)
             IF(BE(I)>0) EL%BE(I)%KIND=BE(I)
          ENDDO
          DEALLOCATE (AN, STAT = error)
          DEALLOCATE (BN, STAT = error)
          DEALLOCATE (AE, STAT = error)
          DEALLOCATE (BE, STAT = error)
       ENDIF
    ENDIF
  END SUBROUTINE UNMAKEPOTKNOB_ELEC

  ! CALL FRINGE_teapot(EL%TP10,X,T%CAS)
  SUBROUTINE fringe_TEAPOTr(EL,X,k,J)
    IMPLICIT NONE
    logical(lp) :: doneitt=.true.
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(TEAPOT),INTENT(IN):: EL
    integer,INTENT(IN):: J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(EL%P%DIR==1) THEN

       IF(J==1) THEN

          IF(EL%P%EDGE(1)/=0.0_dp) THEN
             CALL ROT_XZ(EL%P%EDGE(1),X,EL%P%BETA0,DONEITT,k%TIME)
             CALL FACE(EL%P,EL%BN,EL%H1,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,1,X,k)
             IF(k%FRINGE.or.EL%P%permfringe/=0) then
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k) 
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,1,X,k)
                x(2)=x(2)+EL%P%EDGE(1)*el%bn(2)*(wedge_coeff(1)*x(1)**2-wedge_coeff(2)*x(3)**2*0.5_dp)
                x(4)=x(4)-EL%P%EDGE(1)*el%bn(2)*(wedge_coeff(2)*x(1)*x(3))

             ELSEIF(MAD8_WEDGE) THEN
                x(2)=x(2)+EL%P%EDGE(1)*el%bn(2)*(x(1)**2-x(3)**2)
                x(4)=x(4)-EL%P%EDGE(1)*el%bn(2)*(2.0_dp*x(1)*x(3))
             endif
             CALL WEDGE(-EL%P%EDGE(1),X,k,EL2=EL)
          ELSE
             CALL FACE(EL%P,EL%BN,EL%H1,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,1,X,k)
             IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,1,X,k)
          ENDIF

       ELSE ! J=2

          IF(EL%P%EDGE(2)/=0.0_dp) THEN
             CALL WEDGE(-EL%P%EDGE(2),X,k,EL2=EL)
             IF(k%FRINGE.or.EL%P%permfringe/=0) then
                x(2)=x(2)+EL%P%EDGE(2)*el%bn(2)*(wedge_coeff(1)*x(1)**2-wedge_coeff(2)*x(3)**2*0.5_dp)
                x(4)=x(4)-EL%P%EDGE(2)*el%bn(2)*(wedge_coeff(2)*x(1)*x(3))
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,2,X,k)
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             ELSEIF(MAD8_WEDGE) THEN
                x(2)=x(2)+EL%P%EDGE(2)*el%bn(2)*(x(1)**2-x(3)**2)
                x(4)=x(4)-EL%P%EDGE(2)*el%bn(2)*(2.0_dp*x(1)*x(3))
             endif
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,2,X,k)
             CALL FACE(EL%P,EL%BN,EL%H2,X,k)
             CALL ROT_XZ(EL%P%EDGE(2),X,EL%P%BETA0,DONEITT,k%TIME)
          ELSE
             IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,2,X,k)
             IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,2,X,k)
             CALL FACE(EL%P,EL%BN,EL%H2,X,k)
          ENDIF
       ENDIF ! J=2
    ELSE


       IF(J==1) THEN

          IF(EL%P%EDGE(2)/=0.0_dp) THEN
             CALL ROT_XZ(EL%P%EDGE(2),X,EL%P%BETA0,DONEITT,k%TIME)
             CALL FACE(EL%P,EL%BN,EL%H2,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,2,X,k)
             IF(k%FRINGE.or.EL%P%permfringe/=0) then
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,2,X,k)
                x(2)=x(2)-EL%P%EDGE(2)*el%bn(2)*(wedge_coeff(1)*x(1)**2-wedge_coeff(2)*x(3)**2*0.5_dp)
                x(4)=x(4)+EL%P%EDGE(2)*el%bn(2)*(wedge_coeff(2)*x(1)*x(3))
             ELSEIF(MAD8_WEDGE) THEN
                x(2)=x(2)-EL%P%EDGE(2)*el%bn(2)*(x(1)**2-x(3)**2)
                x(4)=x(4)+EL%P%EDGE(2)*el%bn(2)*(2.0_dp*x(1)*x(3))
             endif
             CALL WEDGE(-EL%P%EDGE(2),X,k,EL2=EL)
          ELSE
             CALL FACE(EL%P,EL%BN,EL%H2,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,2,X,k)
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,2,X,k)
          ENDIF

       ELSE ! J=2

          IF(EL%P%EDGE(1)/=0.0_dp) THEN
             CALL WEDGE(-EL%P%EDGE(1),X,k,EL2=EL)
             IF(k%FRINGE.or.EL%P%permfringe/=0) then
                x(2)=x(2)-EL%P%EDGE(1)*el%bn(2)*(wedge_coeff(1)*x(1)**2-wedge_coeff(2)*x(3)**2*0.5_dp)
                x(4)=x(4)+EL%P%EDGE(1)*el%bn(2)*(wedge_coeff(2)*x(1)*x(3))
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,1,X,k)
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             ELSEIF(MAD8_WEDGE) THEN
                x(2)=x(2)-EL%P%EDGE(1)*el%bn(2)*(x(1)**2-x(3)**2)
                x(4)=x(4)+EL%P%EDGE(1)*el%bn(2)*(2.0_dp*x(1)*x(3))
             endif
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,1,X,k)
             CALL FACE(EL%P,EL%BN,EL%H1,X,k)
             CALL ROT_XZ(EL%P%EDGE(1),X,EL%P%BETA0,DONEITT,k%TIME)
          ELSE
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,1,X,k)
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,1,X,k)
             CALL FACE(EL%P,EL%BN,EL%H1,X,k)
          ENDIF

       ENDIF

    ENDIF

  END SUBROUTINE fringe_TEAPOTr

  SUBROUTINE fringe_TEAPOTP(EL,X,k,J)
    IMPLICIT NONE
    logical(lp) :: doneitt=.true.
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(TEAPOTP),INTENT(IN):: EL
    integer,INTENT(IN):: J

    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(EL%P%DIR==1) THEN

       IF(J==1) THEN

          IF(EL%P%EDGE(1)/=0.0_dp) THEN
             CALL ROT_XZ(EL%P%EDGE(1),X,EL%P%BETA0,DONEITT,k%TIME)
             CALL FACE(EL%P,EL%BN,EL%H1,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,1,X,k)
             IF(k%FRINGE.or.EL%P%permfringe/=0) then
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k) 
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,1,X,k)
                x(2)=x(2)+EL%P%EDGE(1)*el%bn(2)*(wedge_coeff(1)*x(1)**2-wedge_coeff(2)*x(3)**2*0.5_dp)
                x(4)=x(4)-EL%P%EDGE(1)*el%bn(2)*(wedge_coeff(2)*x(1)*x(3))

             ELSEIF(MAD8_WEDGE) THEN
                x(2)=x(2)+EL%P%EDGE(1)*el%bn(2)*(x(1)**2-x(3)**2)
                x(4)=x(4)-EL%P%EDGE(1)*el%bn(2)*(2.0_dp*x(1)*x(3))
             endif
             CALL WEDGE(-EL%P%EDGE(1),X,k,EL2=EL)
          ELSE
             CALL FACE(EL%P,EL%BN,EL%H1,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,1,X,k)
             IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,1,X,k)
          ENDIF

       ELSE ! J=2

          IF(EL%P%EDGE(2)/=0.0_dp) THEN
             CALL WEDGE(-EL%P%EDGE(2),X,k,EL2=EL)
             IF(k%FRINGE.or.EL%P%permfringe/=0) then
                x(2)=x(2)+EL%P%EDGE(2)*el%bn(2)*(wedge_coeff(1)*x(1)**2-wedge_coeff(2)*x(3)**2*0.5_dp)
                x(4)=x(4)-EL%P%EDGE(2)*el%bn(2)*(wedge_coeff(2)*x(1)*x(3))
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,2,X,k)
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             ELSEIF(MAD8_WEDGE) THEN
                x(2)=x(2)+EL%P%EDGE(2)*el%bn(2)*(x(1)**2-x(3)**2)
                x(4)=x(4)-EL%P%EDGE(2)*el%bn(2)*(2.0_dp*x(1)*x(3))
             endif
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,2,X,k)
             CALL FACE(EL%P,EL%BN,EL%H2,X,k)
             CALL ROT_XZ(EL%P%EDGE(2),X,EL%P%BETA0,DONEITT,k%TIME)
          ELSE
             IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,2,X,k)
             IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,2,X,k)
             CALL FACE(EL%P,EL%BN,EL%H2,X,k)
          ENDIF
       ENDIF ! J=2
    ELSE


       IF(J==1) THEN

          IF(EL%P%EDGE(2)/=0.0_dp) THEN
             CALL ROT_XZ(EL%P%EDGE(2),X,EL%P%BETA0,DONEITT,k%TIME)
             CALL FACE(EL%P,EL%BN,EL%H2,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,2,X,k)
             IF(k%FRINGE.or.EL%P%permfringe/=0) then
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,2,X,k)
                x(2)=x(2)-EL%P%EDGE(2)*el%bn(2)*(wedge_coeff(1)*x(1)**2-wedge_coeff(2)*x(3)**2*0.5_dp)
                x(4)=x(4)+EL%P%EDGE(2)*el%bn(2)*(wedge_coeff(2)*x(1)*x(3))
             ELSEIF(MAD8_WEDGE) THEN
                x(2)=x(2)-EL%P%EDGE(2)*el%bn(2)*(x(1)**2-x(3)**2)
                x(4)=x(4)+EL%P%EDGE(2)*el%bn(2)*(2.0_dp*x(1)*x(3))
             endif
             CALL WEDGE(-EL%P%EDGE(2),X,k,EL2=EL)
          ELSE
             CALL FACE(EL%P,EL%BN,EL%H2,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,2,X,k)
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,2,X,k)
          ENDIF

       ELSE ! J=2

          IF(EL%P%EDGE(1)/=0.0_dp) THEN
             CALL WEDGE(-EL%P%EDGE(1),X,k,EL2=EL)
             IF(k%FRINGE.or.EL%P%permfringe/=0) then
                x(2)=x(2)-EL%P%EDGE(1)*el%bn(2)*(wedge_coeff(1)*x(1)**2-wedge_coeff(2)*x(3)**2*0.5_dp)
                x(4)=x(4)+EL%P%EDGE(1)*el%bn(2)*(wedge_coeff(2)*x(1)*x(3))
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,1,X,k)
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             ELSEIF(MAD8_WEDGE) THEN
                x(2)=x(2)-EL%P%EDGE(1)*el%bn(2)*(x(1)**2-x(3)**2)
                x(4)=x(4)+EL%P%EDGE(1)*el%bn(2)*(2.0_dp*x(1)*x(3))
             endif
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,1,X,k)
             CALL FACE(EL%P,EL%BN,EL%H1,X,k)
             CALL ROT_XZ(EL%P%EDGE(1),X,EL%P%BETA0,DONEITT,k%TIME)
          ELSE
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,1,X,k)
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,1,X,k)
             CALL FACE(EL%P,EL%BN,EL%H1,X,k)
          ENDIF

       ENDIF

    ENDIF


  END SUBROUTINE fringe_TEAPOTP


  SUBROUTINE SSYMPINTR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(TEAPOT),INTENT(IN):: EL
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(.NOT.PRESENT(MID))call fringe_TEAPOT(EL,X,k,1)

    CALL SINTE(EL,X,k,MID)

    IF(.NOT.PRESENT(MID))call fringe_TEAPOT(EL,X,k,2)


  END SUBROUTINE SSYMPINTR

  SUBROUTINE SSYMPINTP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(TEAPOTP),INTENT(INOUT):: EL
    ! TYPE(WORM_8),OPTIONAL,INTENT(INOUT):: MID
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    call fringe_TEAPOT(EL,X,k,1)

    CALL SINTE(EL,X,k)

    call fringe_TEAPOT(EL,X,k,2)


  END SUBROUTINE SSYMPINTP

  !  monitor stuff


  SUBROUTINE MONTR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM), OPTIONAL,INTENT(INOUT):: MID
    TYPE(mon),INTENT(INOUT):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(PRESENT(MID)) CALL XMID(MID,X,0)
    DO I=1,EL%P%NST
       CALL MONTI(EL,X,k,I,MID)
    ENDDO
    !    IF(PRESENT(MID)) CALL XMID(MID,X,2)

  END SUBROUTINE MONTR




  SUBROUTINE MONTP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    ! TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: MID
    TYPE(monP),INTENT(INOUT):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)
    DO I=1,EL%P%NST
       CALL MONTI(EL,X,k,I)
    ENDDO
    !    IF(PRESENT(MID)) CALL XMID(MID,X,2)


  END SUBROUTINE MONTP

  SUBROUTINE MONTIR(EL,X,k,I,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM), OPTIONAL,INTENT(INOUT):: MID
    TYPE(mon),INTENT(INOUT):: EL
    INTEGER, INTENT(IN) :: I
    real(dp) DH,DD
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    DH=EL%L/2.0_dp/el%p%nst
    DD=EL%P%LD/2.0_dp/el%p%nst

    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    if(mod(el%p%nst,2)==1) then
       if(i==(el%p%nst+1)/2) THEN
          EL%X=X(1);EL%Y=X(3);
       ENDIF
    endif
    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    if(mod(el%p%nst,2)==0) then
       if(i==el%p%nst/2) THEN
          EL%X=X(1);EL%Y=X(3);
       ENDIF
    ENDIF
    IF(PRESENT(MID))  CALL XMID(MID,X,i)

  END SUBROUTINE MONTIR


  SUBROUTINE MONTIP(EL,X,k,I)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    ! TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: MID
    TYPE(monP),INTENT(INOUT):: EL
    real(dp) DD
    TYPE(REAL_8) DH
    INTEGER, INTENT(IN) :: I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    CALL ALLOC(DH)

    DH=EL%L/2.0_dp/el%p%nst
    DD=EL%P%LD/2.0_dp/el%p%nst

    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    if(mod(el%p%nst,2)==1) then
       if(i==(el%p%nst+1)/2) THEN
          EL%X=X(1);EL%Y=X(3);
       ENDIF
    endif
    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    if(mod(el%p%nst,2)==0) then
       if(i==el%p%nst/2) THEN
          EL%X=X(1);EL%Y=X(3);
       ENDIF
    endif
    !       IF(PRESENT(MID)) CALL XMID(MID,X,i)

    CALL KILL(DH)

  END SUBROUTINE MONTIP

  !  RCOLLIMATOR STUFF

  SUBROUTINE RCOLLIMATORR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM), OPTIONAL,INTENT(INOUT):: MID
    TYPE(RCOL),INTENT(INOUT):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(PRESENT(MID)) CALL XMID(MID,X,0)
    DO I=1,EL%P%NST
       CALL RCOLLIMATORi(EL,X,k,i,MID)
    ENDDO
    !    IF(PRESENT(MID)) CALL XMID(MID,X,2)

  END SUBROUTINE RCOLLIMATORR

  SUBROUTINE RCOLLIMATORP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    ! TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: MID
    TYPE(RCOLP),INTENT(INOUT):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    INTEGER I

    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)
    DO I=1,EL%P%NST
       CALL RCOLLIMATORi(EL,X,k,i)
    ENDDO
    !    IF(PRESENT(MID)) CALL XMID(MID,X,2)

  END SUBROUTINE RCOLLIMATORP

  SUBROUTINE RCOLLIMATORiR(EL,X,k,i,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM), OPTIONAL,INTENT(INOUT):: MID
    TYPE(RCOL),INTENT(INOUT):: EL
    real(dp) DH,DD
    logical(lp) aper
    integer, intent(in) :: i
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    DH=EL%L/2.0_dp/el%p%nst
    DD=EL%P%LD/2.0_dp/el%p%nst

    aper=APERTURE_FLAG
    APERTURE_FLAG=.true.

    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    if(mod(el%p%nst,2)==1) then
       !       IF(PRESENT(MID)) THEN
       !          if(i==(el%p%nst+1)/2)  CALL XMID(MID,X,1)
       !       ENDIF
    endif
    CALL CHECK_APERTURE(EL%p%APERTURE,X)
!    CALL CHECK_APERTURE(EL%A,X)

    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    if(mod(el%p%nst,2)==0) then
       !       IF(PRESENT(MID)) THEN
       !          if(i==el%p%nst/2)  CALL XMID(MID,X,1)
       !       ENDIF
    endif

    IF(PRESENT(MID)) CALL XMID(MID,X,I)

    APERTURE_FLAG=aper

  END SUBROUTINE RCOLLIMATORiR

  SUBROUTINE RCOLLIMATORiP(EL,X,k,i)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    ! TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: MID
    TYPE(RCOLP),INTENT(INOUT):: EL
    real(dp) DD
    TYPE(REAL_8) DH
    logical(lp) aper
    integer, intent(in) :: i
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ALLOC(DH)
    DH=EL%L/2.0_dp/el%p%nst
    DD=EL%P%LD/2.0_dp/el%p%nst

    aper=APERTURE_FLAG
    APERTURE_FLAG=.true.

    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    if(mod(el%p%nst,2)==1) then
       !       IF(PRESENT(MID)) THEN
       !          if(i==(el%p%nst+1)/2)  CALL XMID(MID,X,1)
       !       ENDIF
    endif
     CALL CHECK_APERTURE(EL%p%APERTURE,X)
!    CALL CHECK_APERTURE(EL%A,X)

    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    if(mod(el%p%nst,2)==0) then
       !       IF(PRESENT(MID)) THEN
       !          if(i==el%p%nst/2)  CALL XMID(MID,X,1)
       !       ENDIF
    endif

    !IF(PRESENT(MID)) CALL XMID(MID,X,I)

    APERTURE_FLAG=aper

    CALL kill(DH)

  END SUBROUTINE RCOLLIMATORiP

  !  ECOLLIMATOR STUFF

  SUBROUTINE ECOLLIMATORR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM), OPTIONAL,INTENT(INOUT):: MID
    TYPE(ECOL),INTENT(INOUT):: EL
    !   logical(lp) aper
    !   real(dp) DH,DD
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(PRESENT(MID)) CALL XMID(MID,X,0)
    DO I=1,EL%P%NST
       CALL ECOLLIMATORi(EL,X,k,i,MID)
    ENDDO


    !    DH=EL%L/two
    !    DD=EL%P%LD/two
    !    aper=APERTURE_FLAG
    !    APERTURE_FLAG=.true.
    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)
    !    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    !    CALL CHECK_APERTURE(EL%A,X)
    !    IF(PRESENT(MID)) CALL XMID(MID,X,1)
    !    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    !    IF(PRESENT(MID)) CALL XMID(MID,X,2)
    !    APERTURE_FLAG=aper


  END SUBROUTINE ECOLLIMATORR

  SUBROUTINE ECOLLIMATORP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(ECOLP),INTENT(INOUT):: EL
    ! TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: MID
    !    real(dp) DD
    !    TYPE(REAL_8) DH
    !    logical(lp) aper
    INTEGER I
    !    CALL ALLOC(DH)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K



    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)
    DO I=1,EL%P%NST
       CALL ECOLLIMATORi(EL,X,k,i)
    ENDDO




    !    DH=EL%L/two
    !    DD=EL%P%LD/two
    !    aper=APERTURE_FLAG
    !    APERTURE_FLAG=.true.
    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)
    !    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    !    CALL CHECK_APERTURE(EL%A,X)
    !    IF(PRESENT(MID)) CALL XMID(MID,X,1)
    !    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    !    IF(PRESENT(MID)) CALL XMID(MID,X,2)
    !    APERTURE_FLAG=aper

    !    CALL KILL(DH)

  END SUBROUTINE ECOLLIMATORP

  SUBROUTINE ECOLLIMATORiR(EL,X,k,i,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM), OPTIONAL,INTENT(INOUT):: MID
    TYPE(ECOL),INTENT(INOUT):: EL
    real(dp) DH,DD
    logical(lp) aper
    integer, intent(in) :: i
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    DH=EL%L/2.0_dp/el%p%nst
    DD=EL%P%LD/2.0_dp/el%p%nst

    aper=APERTURE_FLAG
    APERTURE_FLAG=.true.

    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    if(mod(el%p%nst,2)==1) then
       IF(PRESENT(MID)) THEN
          if(i==(el%p%nst+1)/2)  CALL XMID(MID,X,1)
       ENDIF
    endif
    CALL CHECK_APERTURE(EL%p%APERTURE,X)
!    CALL CHECK_APERTURE(EL%A,X)

    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    if(mod(el%p%nst,2)==0) then
       IF(PRESENT(MID)) THEN
          if(i==el%p%nst/2)  CALL XMID(MID,X,1)
       ENDIF
    endif

    APERTURE_FLAG=aper

  END SUBROUTINE ECOLLIMATORiR

  SUBROUTINE ECOLLIMATORiP(EL,X,k,i)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    ! TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: MID
    TYPE(ECOLP),INTENT(INOUT):: EL
    real(dp) DD
    TYPE(REAL_8) DH
    logical(lp) aper
    integer, intent(in) :: i
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ALLOC(DH)
    DH=EL%L/2.0_dp/el%p%nst
    DD=EL%P%LD/2.0_dp/el%p%nst

    aper=APERTURE_FLAG
    APERTURE_FLAG=.true.

    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    !    if(mod(el%p%nst,2)==1) then
    !       IF(PRESENT(MID)) THEN
    !          if(i==(el%p%nst+1)/2)  CALL XMID(MID,X,1)
    !       ENDIF
    !    endif
    CALL CHECK_APERTURE(EL%p%APERTURE,X)
!    CALL CHECK_APERTURE(EL%A,X)
    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    !    if(mod(el%p%nst,2)==0) then
    !       IF(PRESENT(MID)) THEN
    !          if(i==el%p%nst/2)  CALL XMID(MID,X,1)
    !       ENDIF
    !    endif

    APERTURE_FLAG=aper

    CALL kill(DH)

  END SUBROUTINE ECOLLIMATORiP


  SUBROUTINE electric_field_septumR(EL,E,phi,X)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: E(3),X(6),phi
    TYPE(ESEPTUM),INTENT(INOUT):: EL
    real(dp) EM,C1,S1

       EM=EL%VOLT*volt_c/EL%P%P0C
       
       C1=COS(EL%PHAS); S1=SIN(-EL%PHAS)
       E(2)=C1*EM
       E(1)=-S1*EM
       e(3)=0.0_dp
       phi=-E(1)*X(1)-E(2)*X(3)
       
  END SUBROUTINE electric_field_septumR


  SUBROUTINE electric_field_septumP(EL,E,phi,X)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: E(3),X(6),phi
    TYPE(ESEPTUMP),INTENT(INOUT):: EL
    TYPE(REAL_8) EM,C1,S1

     CALL alloc(EM,C1,S1)
       EM=EL%VOLT*volt_c/EL%P%P0C
       
       C1=COS(EL%PHAS); S1=SIN(-EL%PHAS)
       E(2)=C1*EM
       E(1)=-S1*EM
       e(3)=0.0_dp
       phi=-E(1)*X(1)-E(2)*X(3)
      CALL kill(EM,C1,S1)
  END SUBROUTINE electric_field_septumP

  !  Electric septum

  SUBROUTINE SEPR(EL,XO,k,i,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: XO(6)
    TYPE(ESEPTUM),INTENT(INOUT):: EL
    TYPE(WORM), OPTIONAL,INTENT(INOUT):: MID
    real(dp) K1,SH_X,SH,CH,CHM,PZ,E1,XT(2),ARG, X(6),C1,S1
    REAL(DP) DH,DD
    integer, intent(IN) ::i
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

        if(.NOT.EL%P%EXACT) THEN
          DH=EL%L/4.0_dp/el%p%nst 
          DD=EL%P%LD/4.0_dp/el%p%nst 
          CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,MY_FALSE,k%TIME,X)  
          DD=-DD; DH=-DH;   
          CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,MY_TRUE, k%TIME,X)     
       ENDIF
       
       C1=COS(EL%PHAS); S1=SIN(-EL%PHAS)
       X(3)=C1*XO(3)-S1*XO(1)
       X(4)=C1*XO(4)-S1*XO(2)
       X(1)=C1*XO(1)+S1*XO(3)
       X(2)=C1*XO(2)+S1*XO(4)
       X(5)=XO(5)
       X(6)=XO(6)

       K1=EL%P%CHARGE*EL%VOLT*volt_c/EL%P%P0C


       if(k%TIME) then
          PZ=ROOT((1.0_dp/EL%P%BETA0+X(5)+K1*X(3))**2-(EL%P%GAMMA0I/EL%P%BETA0)**2-X(2)**2-X(4)**2)
          E1=1.0_dp/EL%P%BETA0+X(5)
       else
          PZ=ROOT((1.0_dp+X(5)+K1*X(3))**2-X(2)**2-X(4)**2)
          E1=1.0_dp+X(5)
       endif
       ARG=(EL%L/2.0_dp/el%p%nst)*K1/PZ
       SH_X=(EL%L/2.0_dp/el%p%nst)*SINeHX_X(ARG)/PZ
       SH=SINeH(ARG)
       CH=COSeH(ARG)
       ARG=ARG*0.5_dp
       CHM=(EL%L/2.0_dp/el%p%nst)*SINeHX_X(ARG)/PZ*SINeH(ARG)
       ARG=ARG*2.0_dp

       X(1)=X(1)+X(2)*(EL%L/2.0_dp/el%p%nst)/PZ
       XT(1)=CH*X(3)+SH_X*X(4)+CHM*E1
       XT(2)=CH*X(4)+K1*SH*X(3)+SH*E1
       X(6)=X(6)+CHM*X(4)+SH*X(3)+E1*SH_X

       X(3)=XT(1)
       X(4)=XT(2)

       if(k%TIME) then
          X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/EL%P%BETA0/2.0_dp/el%p%nst
       else
          X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/2.0_dp/el%p%nst
       endif

       IF(PRESENT(MID)) THEN
          if(mod(el%p%nst,2)==1) then
             if(i==(el%p%nst+1)/2)  CALL XMID(MID,X,1)
          endif
       ENDIF

       K1=EL%P%CHARGE*EL%VOLT*volt_c/EL%P%P0C    ! added 2004.06.09

       if(k%TIME) then
          PZ=ROOT((1.0_dp/EL%P%BETA0+X(5)+K1*X(3))**2-(EL%P%GAMMA0I/EL%P%BETA0)**2-X(2)**2-X(4)**2)
          E1=1.0_dp/EL%P%BETA0+X(5)
       else
          PZ=ROOT((1.0_dp+X(5)+K1*X(3))**2-X(2)**2-X(4)**2)
          E1=1.0_dp+X(5)
       endif

       ARG=(EL%L/2.0_dp/el%p%nst)*K1/PZ
       SH_X=(EL%L/2.0_dp/el%p%nst)*SINeHX_X(ARG)/PZ
       SH=SINeH(ARG)
       CH=COSeH(ARG)
       ARG=ARG*0.5_dp
       CHM=(EL%L/2.0_dp/el%p%nst)*SINeHX_X(ARG)/PZ*SINeH(ARG)
       ARG=ARG*2.0_dp

       X(1)=X(1)+X(2)*(EL%L/2.0_dp/el%p%nst)/PZ
       XT(1)=CH*X(3)+SH_X*X(4)+CHM*E1
       XT(2)=CH*X(4)+K1*SH*X(3)+SH*E1
       X(6)=X(6)+CHM*X(4)+SH*X(3)+E1*SH_X

       X(3)=XT(1)
       X(4)=XT(2)

       if(k%TIME) then
          X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/EL%P%BETA0/2.0_dp/el%p%nst
       else
          X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/2.0_dp/el%p%nst
       endif

       IF(PRESENT(MID)) THEN
          if(mod(el%p%nst,2)==0) then
             if(i==el%p%nst/2)  CALL XMID(MID,X,1)
          endif
       ENDIF

       XO(3)=C1*X(3)+S1*X(1)
       XO(4)=C1*X(4)+S1*X(2)
       XO(1)=C1*X(1)-S1*X(3)
       XO(2)=C1*X(2)-S1*X(4)
       XO(5)=X(5)
       XO(6)=X(6)

        if(.NOT.EL%P%EXACT) THEN
          DD=-DD; DH=-DH;  
          CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,MY_FALSE,k%TIME,X)  
          DD=-DD; DH=-DH;   
          CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,MY_TRUE, k%TIME,X)     
        ENDIF


  END SUBROUTINE SEPR

  SUBROUTINE SEPP(EL,XO,k,I)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: XO(6)
    TYPE(ESEPTUMP),INTENT(INOUT):: EL
    ! TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: MID
    TYPE(REAL_8) K1,SH_X,SH,CH,CHM,PZ,E1,ARG,DH,C1,S1
    TYPE(REAL_8) X(6),XT(2)
    REAL(DP) DD
    integer, intent(IN) ::i
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

       CALL ALLOC(K1,SH_X,SH,CH,CHM)
       CALL ALLOC(PZ,E1,ARG,DH,C1,S1)
       CALL ALLOC( XT,2)
       CALL ALLOC( X,6)

        if(.NOT.EL%P%EXACT) THEN
          CALL ALLOC(DH)
          DH=EL%L/4.0_dp/el%p%nst 
          DD=EL%P%LD/4.0_dp/el%p%nst 
          CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,MY_FALSE,k%TIME,X)  
          DD=-DD; DH=-DH;   
          CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,MY_TRUE, k%TIME,X)       
       ENDIF




       C1=COS(EL%PHAS); S1=SIN(-EL%PHAS)
       X(3)=C1*XO(3)-S1*XO(1)
       X(4)=C1*XO(4)-S1*XO(2)
       X(1)=C1*XO(1)+S1*XO(3)
       X(2)=C1*XO(2)+S1*XO(4)
       X(5)=XO(5)
       X(6)=XO(6)


       K1=EL%P%CHARGE*EL%VOLT*volt_c/EL%P%P0C


       if(k%TIME) then
          PZ=SQRT((1.0_dp/EL%P%BETA0+X(5)+K1*X(3))**2-(EL%P%GAMMA0I/EL%P%BETA0)**2-X(2)**2-X(4)**2)
          E1=1.0_dp/EL%P%BETA0+X(5)
       else
          PZ=SQRT((1.0_dp+X(5)+K1*X(3))**2-X(2)**2-X(4)**2)
          E1=1.0_dp+X(5)
       endif

       ARG=(EL%L/2.0_dp/el%p%nst)*K1/PZ
       SH_X=(EL%L/2.0_dp/el%p%nst)*SINHX_X(ARG)/PZ
       SH=SINH(ARG)
       CH=COSH(ARG)
       ARG=ARG*0.5_dp
       CHM=(EL%L/2.0_dp/el%p%nst)*SINHX_X(ARG)/PZ*SINH(ARG)
       ARG=2.0_dp*ARG

       X(1)=X(1)+X(2)*(EL%L/2.0_dp/el%p%nst)/PZ
       XT(1)=CH*X(3)+SH_X*X(4)+CHM*E1
       XT(2)=CH*X(4)+K1*SH*X(3)+SH*E1
       X(6)=X(6)+CHM*X(4)+SH*X(3)+E1*SH_X

       X(3)=XT(1)
       X(4)=XT(2)

       if(k%TIME) then
          X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/EL%P%BETA0/2.0_dp/el%p%nst
       else
          X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/2.0_dp/el%p%nst
       endif

      K1=EL%P%CHARGE*EL%VOLT*volt_c/EL%P%P0C    ! added 2004.06.09
       if(k%TIME) then
          PZ=SQRT((1.0_dp/EL%P%BETA0+X(5)+K1*X(3))**2-(EL%P%GAMMA0I/EL%P%BETA0)**2-X(2)**2-X(4)**2)
          E1=1.0_dp/EL%P%BETA0+X(5)
       else
          PZ=SQRT((1.0_dp+X(5)+K1*X(3))**2-X(2)**2-X(4)**2)
          E1=1.0_dp+X(5)
       endif


       ARG=(EL%L/2.0_dp/el%p%nst)*K1/PZ
       SH_X=(EL%L/2.0_dp/el%p%nst)*SINHX_X(ARG)/PZ
       SH=SINH(ARG)
       CH=COSH(ARG)
       ARG=ARG*0.5_dp
       CHM=(EL%L/2.0_dp/el%p%nst)*SINHX_X(ARG)/PZ*SINH(ARG)
       ARG=2.0_dp*ARG

       X(1)=X(1)+X(2)*(EL%L/2.0_dp/el%p%nst)/PZ
       XT(1)=CH*X(3)+SH_X*X(4)+CHM*E1
       XT(2)=CH*X(4)+K1*SH*X(3)+SH*E1
       X(6)=X(6)+CHM*X(4)+SH*X(3)+E1*SH_X

       X(3)=XT(1)
       X(4)=XT(2)

       if(k%TIME) then
          X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/EL%P%BETA0/2.0_dp/el%p%nst
       else
          X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/2.0_dp/el%p%nst
       endif

        if(.NOT.EL%P%EXACT) THEN
          DD=-DD; DH=-DH;  
          CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,MY_FALSE,k%TIME,X)  
          DD=-DD; DH=-DH;   
          CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,MY_TRUE, k%TIME,X)   
          CALL KILL(DH)
       ENDIF

       XO(3)=C1*X(3)+S1*X(1)
       XO(4)=C1*X(4)+S1*X(2)
       XO(1)=C1*X(1)-S1*X(3)
       XO(2)=C1*X(2)-S1*X(4)
       XO(5)=X(5)
       XO(6)=X(6)

       CALL KILL(K1,SH_X,SH,CH,CHM)
       CALL KILL(PZ,E1,ARG,DH,C1,S1)
       CALL KILL( X,6)
       CALL KILL( XT,2)
  END SUBROUTINE SEPP

  SUBROUTINE SYMPSEPR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(ESEPTUM),INTENT(INOUT):: EL
    TYPE(WORM), OPTIONAL,INTENT(INOUT):: MID
    integer i
    !    LOGICAL(LP) EXACT
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(PRESENT(MID)) CALL XMID(MID,X,0)


    do i=1,el%p%nst
       CALL SEPTTRACK(EL,X,k,i,MID)
    enddo

    IF(PRESENT(MID)) CALL XMID(MID,X,1)

  END SUBROUTINE SYMPSEPR

  SUBROUTINE SYMPSEPP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(ESEPTUMP),INTENT(INOUT):: EL
    ! TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: MID
    integer i
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)
    do i=1,el%p%nst
       CALL SEPTTRACK(EL,X,k,i)
    enddo
    !    IF(PRESENT(MID)) CALL XMID(MID,X,1)


  END SUBROUTINE SYMPSEPP

  !  New kind for straigth exact

  SUBROUTINE KICKEXR(EL,YL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(STREX),INTENT(IN):: EL
    real(dp),INTENT(IN):: YL
    real(dp) X1,X3,BBYTW,BBXTW,BBYTWT !,X5
    INTEGER J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    DIR=EL%P%DIR*EL%P%CHARGE

    X1=X(1)
    X3=X(3)

    !   if(k%TIME) then
    !      X5=ROOT(one+two*X(5)/EL%P%beta0+x(5)**2)-one
    !!  else
    !      X5=X(5)
    !   endif

    IF(EL%P%NMUL>=1) THEN
       BBYTW=EL%BN(EL%P%NMUL)
       BBXTW=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,1,-1
          BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
          BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
          BBYTW=BBYTWT
       ENDDO
    ELSE
       BBYTW=0.0_dp
       BBXTW=0.0_dp
    ENDIF


    X(2)=X(2)-YL*DIR*BBYTW
    X(4)=X(4)+YL*DIR*BBXTW

    IF(.NOT.EL%DRIFTKICK) THEN
       X(2)=X(2)+YL*DIR*EL%BN(1)
    ENDIF
    !outvalishev    if(valishev.and.ABS(el%VS)>eps)   then  !valishev
    !outvalishev     call elliptical_b(el%VA,el%VS,x,BBXTW,BBYTW) !valishev
    !outvalishev       X(2)=X(2)-YL*DIR*BBYTW !valishev
    !outvalishev       X(4)=X(4)+YL* DIR*BBXTW !valishev
    !outvalishev    endif !valishev

  END SUBROUTINE KICKEXR

  SUBROUTINE KICKEXP(EL,YL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(STREXP),INTENT(IN):: EL
    TYPE(REAL_8),INTENT(IN):: YL
    TYPE(REAL_8) X1,X3,BBYTW,BBXTW,BBYTWT !5
    INTEGER J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    DIR=EL%P%DIR*EL%P%CHARGE

    CALL ALLOC(X1)
    CALL ALLOC(X3)
    !   CALL ALLOC(X5)
    CALL ALLOC(BBYTW)
    CALL ALLOC(BBXTW)
    CALL ALLOC(BBYTWT)

    X1=X(1)
    X3=X(3)
    !   if(k%TIME) then
    !      X5=SQRT(one+two*X(5)/EL%P%beta0+x(5)**2)-one
    !   else
    !      X5=X(5)
    !   endif


    IF(EL%P%NMUL>=1) THEN
       BBYTW=EL%BN(EL%P%NMUL)
       BBXTW=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,1,-1
          BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
          BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
          BBYTW=BBYTWT
       ENDDO
    ELSE
       BBYTW=0.0_dp
       BBXTW=0.0_dp
    ENDIF

    X(2)=X(2)-YL*DIR*BBYTW
    X(4)=X(4)+YL*DIR*BBXTW
    IF(.NOT.EL%DRIFTKICK) THEN
       X(2)=X(2)+YL*DIR*EL%BN(1)
    ENDIF
    !outvalishev    if(valishev.and.ABS(el%VS)>eps)   then  !valishev
    !outvalishev     call elliptical_b(el%VA,el%VS,x,BBXTW,BBYTW) !valishev
    !outvalishev       X(2)=X(2)-YL*DIR*BBYTW !valishev
    !outvalishev       X(4)=X(4)+YL* DIR*BBXTW !valishev
    !outvalishev    endif !valishev

    CALL KILL(X1)
    CALL KILL(X3)
    !   CALL KILL(X5)
    CALL KILL(BBYTW)
    CALL KILL(BBXTW)
    CALL KILL(BBYTWT)

  END SUBROUTINE KICKEXP

  SUBROUTINE INTER_STREX(EL,X,k,pos)
    IMPLICIT NONE
    TYPE(STREX),INTENT(IN):: EL
    real(dp), INTENT(INOUT) ::  X(6)
    real(dp) D,DH,DD
    real(dp) D1,D2,DK1,DK2
    real(dp) DD1,DD2
    real(dp) DF(4),DK(4),DDF(4)
    INTEGER I,J,f1,pos
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(EL%DRIFTKICK) THEN

       SELECT CASE(EL%P%METHOD)
       CASE(1)
          if(EL%F==1) then
             f1=0
          else
             f1=EL%F+1
          endif
          DH=EL%L/EL%P%NST
          D=EL%L/(EL%P%NST/EL%F/2)
          DD=EL%P%LD/EL%P%NST

          IF(MOD(POS,2*EL%F)==f1) THEN
             CALL KICKEX (EL,D,X,k)
          ENDIF
          CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CASE(2)
          DH=EL%L/2.0_dp/EL%P%NST
          D=EL%L/EL%P%NST
          DD=EL%P%LD/2.0_dp/EL%P%NST

          CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICKEX (EL,D,X,k)
          CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)

       CASE(4)
          D1=EL%L*FD1/EL%P%NST
          D2=EL%L*FD2/EL%P%NST
          DD1=EL%P%LD*FD1/EL%P%NST
          DD2=EL%P%LD*FD2/EL%P%NST
          DK1=EL%L*FK1/EL%P%NST
          DK2=EL%L*FK2/EL%P%NST

          CALL DRIFT(D1,DD1,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICKEX (EL,DK1,X,k)
          CALL DRIFT(D2,DD2,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICKEX (EL,DK2,X,k)
          CALL DRIFT(D2,DD2,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICKEX (EL,DK1,X,k)
          CALL DRIFT(D1,DD1,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)

       CASE(6)
          DO I =1,4
             DF(I)=EL%L*YOSD(I)/EL%P%NST
             DDF(I)=EL%P%LD*YOSD(I)/EL%P%NST
             DK(I)=EL%L*YOSK(I)/EL%P%NST
          ENDDO

          DO J=4,2,-1
             CALL DRIFT(DF(J),DDF(J),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
             CALL KICKEX (EL,DK(J),X,k)
          ENDDO
          CALL DRIFT(DF(1),DDF(1),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICKEX (EL,DK(1),X,k)
          CALL DRIFT(DF(1),DDF(1),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          DO J=2,4
             CALL KICKEX (EL,DK(J),X,k)
             CALL DRIFT(DF(J),DDF(J),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          ENDDO

       CASE DEFAULT
          w_p=0
          w_p%nc=1
          w_p%fc='(1(1X,A72))'
          WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
          ! call !write_e(357)
       END SELECT
    ELSE
       SELECT CASE(EL%P%METHOD)
       CASE(2)
          DH=EL%L/2.0_dp/EL%P%NST
          D=EL%L/EL%P%NST
          DD=EL%P%LD/2.0_dp/EL%P%NST

          CALL SPAR(EL,DH,DD,X,k)
          CALL KICKEX (EL,D,X,k)
          CALL SPAR(EL,DH,DD,X,k)

       CASE(4)
          D1=EL%L*FD1/EL%P%NST
          D2=EL%L*FD2/EL%P%NST
          DD1=EL%P%LD*FD1/EL%P%NST
          DD2=EL%P%LD*FD2/EL%P%NST
          DK1=EL%L*FK1/EL%P%NST
          DK2=EL%L*FK2/EL%P%NST

          CALL SPAR(EL,D1,DD1,X,k)
          CALL KICKEX (EL,DK1,X,k)
          CALL SPAR(EL,D2,DD2,X,k)
          CALL KICKEX (EL,DK2,X,k)
          CALL SPAR(EL,D2,DD2,X,k)
          CALL KICKEX (EL,DK1,X,k)
          CALL SPAR(EL,D1,DD1,X,k)

       CASE(6)
          DO I =1,4
             DF(I)=EL%L*YOSD(I)/EL%P%NST
             DDF(I)=EL%P%LD*YOSD(I)/EL%P%NST
             DK(I)=EL%L*YOSK(I)/EL%P%NST
          ENDDO

          DO J=4,2,-1
             CALL SPAR(EL,DF(J),DDF(J),X,k)
             CALL KICKEX (EL,DK(J),X,k)
          ENDDO
          CALL SPAR(EL,DF(1),DDF(1),X,k)
          CALL KICKEX (EL,DK(1),X,k)
          CALL SPAR(EL,DF(1),DDF(1),X,k)
          DO J=2,4
             CALL KICKEX (EL,DK(J),X,k)
             CALL SPAR(EL,DF(J),DDF(J),X,k)
          ENDDO

       CASE DEFAULT
          w_p=0
          w_p%nc=1
          w_p%fc='(1(1X,A72))'
          WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
          ! call !write_e(357)
       END SELECT

    ENDIF


  END SUBROUTINE INTER_STREX

  SUBROUTINE INTEP_STREX(EL,X,k,pos)
    IMPLICIT NONE
    TYPE(STREXP),INTENT(IN):: EL
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    real(dp) DD
    real(dp) DD1,DD2
    real(dp) DDF(4)
    TYPE(REAL_8) DH,D,D1,D2,DK1,DK2,DF(4),DK(4)
    INTEGER I,J,f1,pos
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(EL%DRIFTKICK) THEN

       SELECT CASE(EL%P%METHOD)
       CASE(1)
          if(EL%F==1) then
             f1=0
          else
             f1=EL%F+1
          endif
          CALL ALLOC(DH,D)
          DH=EL%L/EL%P%NST
          D=EL%L/(EL%P%NST/EL%F/2)
          DD=EL%P%LD/EL%P%NST

          IF(MOD(POS,2*EL%F)==f1) THEN
             CALL KICKEX (EL,D,X,k)
          ENDIF
          CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL kill(DH,D)
       CASE(2)
          CALL ALLOC(DH,D)
          DH=EL%L/2.0_dp/EL%P%NST
          D=EL%L/EL%P%NST
          DD=EL%P%LD/2.0_dp/EL%P%NST

          CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICKEX (EL,D,X,k)
          CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KILL(DH,D)

       CASE(4)
          CALL ALLOC(D1,D2,DK1,DK2)
          D1=EL%L*FD1/EL%P%NST
          D2=EL%L*FD2/EL%P%NST
          DD1=EL%P%LD*FD1/EL%P%NST
          DD2=EL%P%LD*FD2/EL%P%NST
          DK1=EL%L*FK1/EL%P%NST
          DK2=EL%L*FK2/EL%P%NST

          CALL DRIFT(D1,DD1,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICKEX (EL,DK1,X,k)
          CALL DRIFT(D2,DD2,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICKEX (EL,DK2,X,k)
          CALL DRIFT(D2,DD2,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICKEX (EL,DK1,X,k)
          CALL DRIFT(D1,DD1,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KILL(D1,D2,DK1,DK2)

       CASE(6)
          CALL ALLOC(DF,4);CALL ALLOC(DK,4);
          DO I =1,4
             DF(I)=EL%L*YOSD(I)/EL%P%NST
             DDF(I)=EL%P%LD*YOSD(I)/EL%P%NST
             DK(I)=EL%L*YOSK(I)/EL%P%NST
          ENDDO

          DO J=4,2,-1
             CALL DRIFT(DF(J),DDF(J),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
             CALL KICKEX (EL,DK(J),X,k)
          ENDDO
          CALL DRIFT(DF(1),DDF(1),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICKEX (EL,DK(1),X,k)
          CALL DRIFT(DF(1),DDF(1),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          DO J=2,4
             CALL KICKEX (EL,DK(J),X,k)
             CALL DRIFT(DF(J),DDF(J),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          ENDDO
          CALL KILL(DF,4);CALL KILL(DK,4);

       CASE DEFAULT
          w_p=0
          w_p%nc=1
          w_p%fc='(1(1X,A72))'
          WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
          ! call !write_e(357)
       END SELECT
    ELSE
       SELECT CASE(EL%P%METHOD)
       CASE(2)
          CALL ALLOC(DH,D)
          DH=EL%L/2.0_dp/EL%P%NST
          D=EL%L/EL%P%NST
          DD=EL%P%LD/2.0_dp/EL%P%NST

          CALL SPAR(EL,DH,DD,X,k)
          CALL KICKEX (EL,D,X,k)
          CALL SPAR(EL,DH,DD,X,k)
          CALL KILL(DH,D)

       CASE(4)
          CALL ALLOC(D1,D2,DK1,DK2)
          D1=EL%L*FD1/EL%P%NST
          D2=EL%L*FD2/EL%P%NST
          DD1=EL%P%LD*FD1/EL%P%NST
          DD2=EL%P%LD*FD2/EL%P%NST
          DK1=EL%L*FK1/EL%P%NST
          DK2=EL%L*FK2/EL%P%NST

          CALL SPAR(EL,D1,DD1,X,k)
          CALL KICKEX (EL,DK1,X,k)
          CALL SPAR(EL,D2,DD2,X,k)
          CALL KICKEX (EL,DK2,X,k)
          CALL SPAR(EL,D2,DD2,X,k)
          CALL KICKEX (EL,DK1,X,k)
          CALL SPAR(EL,D1,DD1,X,k)
          CALL KILL(D1,D2,DK1,DK2)

       CASE(6)
          CALL ALLOC(DF,4);CALL ALLOC(DK,4);
          DO I =1,4
             DF(I)=EL%L*YOSD(I)/EL%P%NST
             DDF(I)=EL%P%LD*YOSD(I)/EL%P%NST
             DK(I)=EL%L*YOSK(I)/EL%P%NST
          ENDDO

          DO J=4,2,-1
             CALL SPAR(EL,DF(J),DDF(J),X,k)
             CALL KICKEX (EL,DK(J),X,k)
          ENDDO
          CALL SPAR(EL,DF(1),DDF(1),X,k)
          CALL KICKEX (EL,DK(1),X,k)
          CALL SPAR(EL,DF(1),DDF(1),X,k)
          DO J=2,4
             CALL KICKEX (EL,DK(J),X,k)
             CALL SPAR(EL,DF(J),DDF(J),X,k)
          ENDDO
          CALL KILL(DF,4);CALL KILL(DK,4);

       CASE DEFAULT
          w_p=0
          w_p%nc=1
          w_p%fc='(1(1X,A72))'
          WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
          ! call !write_e(357)
       END SELECT

    ENDIF


  END SUBROUTINE INTEP_STREX

  SUBROUTINE INTEEXR(EL,X,k,MID)
    IMPLICIT NONE
    TYPE(STREX),INTENT(IN):: EL
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM) ,OPTIONAL,INTENT(INOUT):: MID
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    INTEGER I

    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    DO I=1,EL%P%NST
       IF(.NOT.PRESENT(MID))CALL TRACK_SLICE(EL,X,k,i)
       IF(PRESENT(MID)) CALL XMID(MID,X,I)
    ENDDO


  END SUBROUTINE INTEEXR





  SUBROUTINE INTEEXP(EL,X,k)
    IMPLICIT NONE
    TYPE(STREXP),INTENT(IN):: EL
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    INTEGER I


    DO I=1,EL%P%NST
       CALL TRACK_SLICE(EL,X,k,i)
    ENDDO

  END SUBROUTINE INTEEXP

  SUBROUTINE  fringe_STREXr(EL,X,k,J)
    IMPLICIT NONE
    logical(lp) :: doneitt=.true.
    integer,INTENT(IN):: J
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(STREX),INTENT(IN):: EL
    real(dp) ANGH

    ! J=1 front
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(EL%P%DIR==1) THEN

       IF(J==1) THEN

          IF(EL%LIKEMAD) THEN

             ANGH=EL%P%B0*EL%P%LD*0.5_dp-EL%P%EDGE(1)
             CALL ROT_XZ(EL%P%EDGE(1),X,EL%P%BETA0,DONEITT,k%TIME)
             CALL FACE(EL%P,EL%BN,EL%H1,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,1,X,k)
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,1,X,k)
             CALL  WEDGE(ANGH,X,k,EL1=EL)

          ELSE
             CALL EDGE_TRUE_PARALLEL(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,1,X,k)
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,1,X,k)
          ENDIF

       ELSE  ! J==2


          IF(EL%LIKEMAD) THEN
             ANGH=EL%P%B0*EL%P%LD*0.5_dp-EL%P%EDGE(2)
             CALL  WEDGE(ANGH,X,k,EL1=EL)
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,2,X,k)
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,2,X,k)
             CALL FACE(EL%P,EL%BN,EL%H2,X,k)
             CALL ROT_XZ(EL%P%EDGE(2),X,EL%P%BETA0,DONEITT,k%TIME)
          ELSE
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,2,X,k)
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             CALL EDGE_TRUE_PARALLEL(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,2,X,k)
          ENDIF

       ENDIF ! J

    ELSE

       IF(J==1) THEN

          IF(EL%LIKEMAD) THEN

             ANGH=EL%P%B0*EL%P%LD*0.5_dp-EL%P%EDGE(2)
             CALL ROT_XZ(EL%P%EDGE(2),X,EL%P%BETA0,DONEITT,k%TIME)
             CALL FACE(EL%P,EL%BN,EL%H2,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,2,X,k)
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,2,X,k)
             CALL  WEDGE(ANGH,X,k,EL1=EL)
          ELSE
             CALL EDGE_TRUE_PARALLEL(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,2,X,k)
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,2,X,k)
          ENDIF


       ELSE ! J==2

          IF(EL%LIKEMAD) THEN
             ANGH=EL%P%B0*EL%P%LD*0.5_dp-EL%P%EDGE(1)
             CALL  WEDGE(ANGH,X,k,EL1=EL)
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,1,X,k)
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,1,X,k)
             CALL FACE(EL%P,EL%BN,EL%H1,X,k)
             CALL ROT_XZ(EL%P%EDGE(1),X,EL%P%BETA0,DONEITT,k%TIME)
          ELSE
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,1,X,k)
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             CALL EDGE_TRUE_PARALLEL(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,1,X,k)
          ENDIF

       ENDIF ! J

    ENDIF

  END SUBROUTINE fringe_STREXr

  SUBROUTINE  fringe_STREXP(EL,X,k,J)
    IMPLICIT NONE
    logical(lp) :: doneitt=.true.
    integer,INTENT(IN):: J
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(STREXP),INTENT(IN):: EL
    real(dp) ANGH
    ! J=1 front
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

     IF(EL%P%DIR==1) THEN

       IF(J==1) THEN

          IF(EL%LIKEMAD) THEN

             ANGH=EL%P%B0*EL%P%LD*0.5_dp-EL%P%EDGE(1)
             CALL ROT_XZ(EL%P%EDGE(1),X,EL%P%BETA0,DONEITT,k%TIME)
             CALL FACE(EL%P,EL%BN,EL%H1,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,1,X,k)
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,1,X,k)
             CALL  WEDGE(ANGH,X,k,EL1=EL)

          ELSE
             CALL EDGE_TRUE_PARALLEL(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,1,X,k)
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,1,X,k)
          ENDIF

       ELSE  ! J==2


          IF(EL%LIKEMAD) THEN
             ANGH=EL%P%B0*EL%P%LD*0.5_dp-EL%P%EDGE(2)
             CALL  WEDGE(ANGH,X,k,EL1=EL)
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,2,X,k)
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,2,X,k)
             CALL FACE(EL%P,EL%BN,EL%H2,X,k)
             CALL ROT_XZ(EL%P%EDGE(2),X,EL%P%BETA0,DONEITT,k%TIME)
          ELSE
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,2,X,k)
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             CALL EDGE_TRUE_PARALLEL(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,2,X,k)
          ENDIF

       ENDIF ! J

    ELSE

       IF(J==1) THEN

          IF(EL%LIKEMAD) THEN

             ANGH=EL%P%B0*EL%P%LD*0.5_dp-EL%P%EDGE(2)
             CALL ROT_XZ(EL%P%EDGE(2),X,EL%P%BETA0,DONEITT,k%TIME)
             CALL FACE(EL%P,EL%BN,EL%H2,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,2,X,k)
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,2,X,k)
             CALL  WEDGE(ANGH,X,k,EL1=EL)
          ELSE
             CALL EDGE_TRUE_PARALLEL(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,2,X,k)
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,2,X,k)
          ENDIF


       ELSE ! J==2

          IF(EL%LIKEMAD) THEN
             ANGH=EL%P%B0*EL%P%LD*0.5_dp-EL%P%EDGE(1)
             CALL  WEDGE(ANGH,X,k,EL1=EL)
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,1,X,k)
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,1,X,k)
             CALL FACE(EL%P,EL%BN,EL%H1,X,k)
             CALL ROT_XZ(EL%P%EDGE(1),X,EL%P%BETA0,DONEITT,k%TIME)
          ELSE
                IF(el%p%permfringe==2.or.el%p%permfringe==3) CALL FRINGE2QUAD(EL%P,EL%bn(2),EL%an(2),EL%VA,EL%VS,1,X,k)
                IF(k%FRINGE.or.el%p%permfringe==1.or.el%p%permfringe==3)CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             CALL EDGE_TRUE_PARALLEL(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,1,X,k)
          ENDIF

       ENDIF ! J

    ENDIF

  END SUBROUTINE fringe_STREXP

  SUBROUTINE SYMPINTEXR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(STREX),INTENT(IN):: EL
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    !etienne
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(.NOT.PRESENT(MID))CALL fringe_STREX(EL,X,k,1)

    CALL INTE_strex(EL,X,k,mid)

    IF(.NOT.PRESENT(MID))CALL fringe_STREX(EL,X,k,2)





  END SUBROUTINE SYMPINTEXR

  SUBROUTINE SYMPINTEXP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(STREXP),INTENT(IN):: EL
    ! TYPE(WORM_8),OPTIONAL,INTENT(INOUT):: MID
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL fringe_STREX(EL,X,k,1)

    CALL INTE_strex(EL,X,k)

    CALL fringe_STREX(EL,X,k,2)

  END SUBROUTINE SYMPINTEXP

  SUBROUTINE SPARr(EL,YL,DL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN):: YL,DL
    TYPE(STREX),INTENT(IN):: EL
    real(dp) XN(6),PZ,PZS,PT
    real(dp)  b
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    DIR=EL%P%DIR*EL%P%CHARGE

    if(k%TIME) then
       B=EL%P%BETA0
       PZ=ROOT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(2)**2-X(4)**2)
       XN(2)=X(2)-YL*DIR*EL%BN(1)
       PT=ROOT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(4)**2)
       PZS=ROOT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-XN(2)**2-X(4)**2)
       XN(1)=X(1)+(PZS-PZ)/DIR/EL%BN(1)

       XN(3)=(ARCSIN(X(2)/PT)-ARCSIN(XN(2)/PT))/DIR/EL%BN(1)

       XN(6)=X(6)+XN(3)*(1.0_dp/b+x(5))
       XN(6)=XN(6)+(k%TOTALPATH-1)*DL/b

       XN(3)=X(3)+X(4)*XN(3)
    else
       PZ=ROOT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
       XN(2)=X(2)-YL*DIR*EL%BN(1)
       PT=ROOT((1.0_dp+X(5))**2-X(4)**2)
       PZS=ROOT((1.0_dp+X(5))**2-XN(2)**2-X(4)**2)
       XN(1)=X(1)+(PZS-PZ)/DIR/EL%BN(1)

       XN(3)=(ARCSIN(X(2)/PT)-ARCSIN(XN(2)/PT))/DIR/EL%BN(1)

       XN(6)=X(6)+XN(3)*(1.0_dp+X(5))
       XN(6)=XN(6)+(k%TOTALPATH-1)*DL

       XN(3)=X(3)+X(4)*XN(3)

    endif
    X(1)=XN(1)
    X(2)=XN(2)
    X(3)=XN(3)
    X(6)=XN(6)

  END SUBROUTINE SPARr

  SUBROUTINE SPARP(EL,YL,DL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN):: YL
    real(dp),INTENT(IN):: DL
    TYPE(STREXP),INTENT(IN):: EL
    TYPE(REAL_8) XN(6),PZ,PZS,PT
    real(dp)  b
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    DIR=EL%P%DIR*EL%P%CHARGE

    CALL ALLOC(XN,6)
    CALL ALLOC(PZ,PZS,PT)

    if(k%TIME) then
       B=EL%P%BETA0
       PZ=SQRT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(2)**2-X(4)**2)
       XN(2)=X(2)-YL*DIR*EL%BN(1)
       PT=SQRT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(4)**2)
       PZS=SQRT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-XN(2)**2-X(4)**2)
       XN(1)=X(1)+(PZS-PZ)/DIR/EL%BN(1)

       XN(3)=(ASIN(X(2)/PT)-ASIN(XN(2)/PT))/DIR/EL%BN(1)

       XN(6)=X(6)+XN(3)*(1.0_dp/b+x(5))
       XN(6)=XN(6)+(k%TOTALPATH-1)*DL/b

       XN(3)=X(3)+X(4)*XN(3)
    else
       PZ=SQRT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
       XN(2)=X(2)-YL*DIR*EL%BN(1)
       PT=SQRT((1.0_dp+X(5))**2-X(4)**2)
       PZS=SQRT((1.0_dp+X(5))**2-XN(2)**2-X(4)**2)
       XN(1)=X(1)+(PZS-PZ)/DIR/EL%BN(1)

       XN(3)=(ASIN(X(2)/PT)-ASIN(XN(2)/PT))/DIR/EL%BN(1)

       XN(6)=X(6)+XN(3)*(1.0_dp+X(5))
       XN(6)=XN(6)+(k%TOTALPATH-1)*DL

       XN(3)=X(3)+X(4)*XN(3)

    endif
    X(1)=XN(1)
    X(2)=XN(2)
    X(3)=XN(3)
    X(6)=XN(6)

    CALL KILL(XN,6)
    CALL KILL(PZ,PZS,PT)


  END SUBROUTINE SPARP

  SUBROUTINE check_root_drift(p,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    type(magnet_chart),intent(in):: p
    real(dp) PZ
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(P%EXACT) THEN
       if(k%TIME) then
          PZ=ROOT(1.0_dp+2.0_dp*X(5)/P%BETA0+x(5)**2-X(2)**2-X(4)**2)
       else
          PZ=ROOT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
       endif
    ENDIF
    !       write(30,*) x(1:5),c_%check_stable
    if(.not.c_%check_stable)x=0.0_dp

  END SUBROUTINE check_root_drift


  SUBROUTINE wedger(A,X,k,EL1,EL2)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN):: A
    TYPE(STREX),optional,INTENT(IN):: EL1
    TYPE(TEAPOT),optional,INTENT(IN):: EL2
    real(dp) XN(6),PZ,PZS,PT,B1
    real(dp)  b
    integer TOTALPATH
    logical(lp) time,EXACT
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    EXACT=.TRUE.

    !    if(abs(x(1))+abs(x(3))+abs(x(2))+abs(x(4))>absolute_aperture.or.(.not.CHECK_MADX_APERTURE)) then
    !       if(CHECK_MADX_APERTURE) c_%message="exceed absolute_aperture in wedger"
    !       CHECK_STABLE=.false.
    !    endif
    !    if(.not.CHECK_STABLE) return


    IF(PRESENT(EL1)) THEN
       B1=EL1%P%DIR*EL1%P%CHARGE*EL1%BN(1)
       B=EL1%P%BETA0
       TOTALPATH=k%TOTALPATH
       time=k%TIME
       b=EL1%P%BETA0
    ELSEIF(PRESENT(EL2)) THEN
       B1=EL2%P%DIR*EL2%P%CHARGE*EL2%BN(1)
       B=EL2%P%BETA0
       TOTALPATH=k%TOTALPATH
       time=k%TIME
       b=EL2%P%BETA0
    ELSE
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       w_p%c(1)= " ERROR IN WEDGER "
       ! call !write_e(101)
    ENDIF

    IF(B1==0.0_dp) THEN
       call ROT_XZ(A,X,B,EXACT,time)

    ELSE


       if(TIME) then
          PZ=ROOT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(2)**2-X(4)**2)

          XN(2)=X(2)*COS(A)+(PZ-B1*X(1))*SIN(A)

          PT=ROOT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(4)**2)
          PZS=ROOT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-XN(2)**2-X(4)**2)

          XN(1)=X(1)*COS(A)+(X(1)*X(2)*SIN(2.0_dp*A)+SIN(A)**2*(2.0_dp*X(1)*PZ-B1*X(1)**2) )&
               & /(PZS+PZ*COS(A)-X(2)*SIN(A))
          XN(3)=(A+ARCSIN(X(2)/PT)-ARCSIN(XN(2)/PT))/B1

          XN(6)=X(6)+XN(3)*(1.0_dp/b+x(5))

          XN(3)=X(3)+X(4)*XN(3)
       else
          PZ=ROOT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          XN(2)=X(2)*COS(A)+(PZ-B1*X(1))*SIN(A)
          PT=ROOT((1.0_dp+X(5))**2-X(4)**2)
          PZS=ROOT((1.0_dp+X(5))**2-XN(2)**2-X(4)**2)
          XN(1)=X(1)*COS(A)+(X(1)*X(2)*SIN(2.0_dp*A)+SIN(A)**2*(2.0_dp*X(1)*PZ-B1*X(1)**2))&
               & /(PZS+PZ*COS(A)-X(2)*SIN(A))

          XN(3)=(A+ARCSIN(X(2)/PT)-ARCSIN(XN(2)/PT))/B1

          XN(6)=X(6)+XN(3)*(1.0_dp+X(5))

          XN(3)=X(3)+X(4)*XN(3)

       endif
       X(1)=XN(1)
       X(2)=XN(2)
       X(3)=XN(3)
       X(6)=XN(6)
    ENDIF
    !    CALL CHECK_STABILITY(X)

  END SUBROUTINE wedger


  SUBROUTINE wedgeP(A,X,k,EL1,EL2)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN):: A
    TYPE(STREXP),optional,INTENT(IN):: EL1
    TYPE(TEAPOTP),optional,INTENT(IN):: EL2
    TYPE(REAL_8) XN(6),PZ,PZS,PT,B1
    real(dp)  b
    integer TOTALPATH
    logical(lp) time,EXACT
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    EXACT=.TRUE.

    CALL ALLOC(PZ,PZS,PT,B1)
    CALL ALLOC(XN,6)


    IF(PRESENT(EL1)) THEN
       B1=EL1%P%DIR*EL1%P%CHARGE*EL1%BN(1)
       B=EL1%P%BETA0
       TOTALPATH=k%TOTALPATH
       time=k%TIME
       b=EL1%P%BETA0
    ELSEIF(PRESENT(EL2)) THEN
       B1=EL2%P%DIR*EL2%P%CHARGE*EL2%BN(1)
       B=EL2%P%BETA0
       TOTALPATH=k%TOTALPATH
       time=k%TIME
       b=EL2%P%BETA0
    ELSE
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       w_p%c(1)= " ERROR IN WEDGEP "
       ! call !write_e(102)
    ENDIF

    IF(B1==0.0_dp) THEN
       call ROT_XZ(A,X,B,EXACT,time)

    ELSE

       if(TIME) then
          PZ=SQRT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(2)**2-X(4)**2)
          XN(2)=X(2)*COS(A)+(PZ-B1*X(1))*SIN(A)
          PT=SQRT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(4)**2)
          PZS=SQRT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-XN(2)**2-X(4)**2)
          XN(1)=X(1)*COS(A)+(X(1)*X(2)*SIN(2.0_dp*A)+SIN(A)**2*(2.0_dp*X(1)*PZ-B1*X(1)**2))&
               & /(PZS+PZ*COS(A)-X(2)*SIN(A))

          XN(3)=(A+ASIN(X(2)/PT)-ASIN(XN(2)/PT))/B1

          XN(6)=X(6)+XN(3)*(1.0_dp/b+x(5))

          XN(3)=X(3)+X(4)*XN(3)
       else
          PZ=SQRT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          XN(2)=X(2)*COS(A)+(PZ-B1*X(1))*SIN(A)
          PT=SQRT((1.0_dp+X(5))**2-X(4)**2)
          PZS=SQRT((1.0_dp+X(5))**2-XN(2)**2-X(4)**2)
          XN(1)=X(1)*COS(A)+(X(1)*X(2)*SIN(2.0_dp*A)+SIN(A)**2*(2.0_dp*X(1)*PZ-B1*X(1)**2))&
               & /(PZS+PZ*COS(A)-X(2)*SIN(A))

          XN(3)=(A+ASIN(X(2)/PT)-ASIN(XN(2)/PT))/B1

          XN(6)=X(6)+XN(3)*(1.0_dp+X(5))

          XN(3)=X(3)+X(4)*XN(3)

       endif
       X(1)=XN(1)
       X(2)=XN(2)
       X(3)=XN(3)
       X(6)=XN(6)
    ENDIF
    CALL KILL(PZ,PZS,PT,B1)
    CALL KILL(XN,6)

  END SUBROUTINE wedgeP

  !  CAV_TRAV

  SUBROUTINE ADJUSTR_TIME_CAV_TRAV_OUT(EL,X,k,J)
    IMPLICIT NONE
    REAL(DP), INTENT(INOUT) :: X(6)
    TYPE(CAV_TRAV),INTENT(INOUT):: EL
    integer,INTENT(IN):: J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(J==1) RETURN

    if(k%TIME) then
       X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/EL%P%BETA0
    else
       X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD
    endif

  END SUBROUTINE ADJUSTR_TIME_CAV_TRAV_OUT

  SUBROUTINE ADJUSTP_TIME_CAV_TRAV_OUT(EL,X,k,J)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(CAV_TRAVP),INTENT(INOUT):: EL
    integer,INTENT(IN):: J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(J==1) RETURN

    if(k%TIME) then
       X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/EL%P%BETA0
    else
       X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD
    endif

  END SUBROUTINE ADJUSTP_TIME_CAV_TRAV_OUT

  SUBROUTINE INTER_CAV_TRAV(EL,X,kt,j)
    IMPLICIT NONE
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(CAV_TRAV),INTENT(INOUT):: EL

    integer , INTENT(IN) :: j
    real(dp) D1
    REAL(DP) Z0
    INTEGER TOTALPATH
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    TYPE(INTERNAL_STATE) kt !,OPTIONAL :: K

    D1=el%p%dir*EL%L/EL%P%NST
    IF(EL%P%DIR==1) THEN
       Z0=(j-1)*d1
    ELSE
       Z0=EL%L+(j-1)*d1
    ENDIF

    k=kt
    TOTALPATH=k%TOTALPATH
    k%TOTALPATH=1
    SELECT CASE(EL%P%METHOD)
    CASE(2)

       call rk2_cav(z0,d1,el,X,k)

    CASE(4)

       call rk4_cav(z0,d1,el,X,k)

    CASE(6)

       call rk6_cav(z0,d1,el,X,k)
    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

    !    IF(k%FRINGE)

    k%TOTALPATH=TOTALPATH

  END SUBROUTINE INTER_CAV_TRAV

  SUBROUTINE INTEP_CAV_TRAV(EL,X,kt,j)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(CAV_TRAVP),INTENT(INOUT):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    TYPE(INTERNAL_STATE) kt !,OPTIONAL :: K

    !    TYPE(REAL_8), INTENT(IN) :: Z
    integer, INTENT(IN) :: j
    TYPE(REAL_8) Z0,D1
    INTEGER TOTALPATH

    CALL ALLOC(Z0,D1)

    D1=el%p%dir*EL%L/EL%P%NST
    IF(EL%P%DIR==1) THEN
       Z0=(j-1)*d1
    ELSE
       Z0=EL%L+(j-1)*d1
    ENDIF
    k=kt
    TOTALPATH=k%TOTALPATH
    k%TOTALPATH=1

    SELECT CASE(EL%P%METHOD)
    CASE(2)

       call rk2_cav(z0,d1,el,X,k)

    CASE(4)

       call rk4_cav(z0,d1,el,X,k)

    CASE(6)

       call rk6_cav(z0,d1,el,X,k)

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

    !    IF(k%FRINGE)

    k%TOTALPATH=TOTALPATH

    CALL KILL(Z0,D1)


  END SUBROUTINE INTEP_CAV_TRAV


  SUBROUTINE CAVER_TRAV(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(CAV_TRAV),INTENT(INOUT):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    !    IF(k%FRINGE)
    !
    IF(.NOT.PRESENT(MID))CALL FRINGE_CAV_TRAV(EL,X,k,1)

    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    DO I=1,EL%P%NST
       IF(.NOT.PRESENT(MID)) call track_slice(el,x,k,i)
       IF(PRESENT(MID)) CALL XMID(MID,X,I)
    ENDDO
    !
    IF(.NOT.PRESENT(MID))CALL FRINGE_CAV_TRAV(EL,X,k,2)


    call ADJUST_TIME_CAV_TRAV_OUT(EL,X,k,2)

  END SUBROUTINE CAVER_TRAV

  SUBROUTINE CAVEP_TRAV(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(CAV_TRAVP),INTENT(INOUT):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    !    IF(k%FRINGE)
    CALL FRINGE_CAV_TRAV(EL,X,k,1)


    DO I=1,EL%P%NST
       call track_slice(el,x,k,i)
    ENDDO

    CALL FRINGE_CAV_TRAV(EL,X,k,2)


    call ADJUST_TIME_CAV_TRAV_OUT(EL,X,k,2)

  END SUBROUTINE CAVEP_TRAV

  SUBROUTINE FRINGECAVR_TRAV(EL,I,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(CAV_TRAV),INTENT(INOUT):: EL
    integer, intent(in) :: i
    real(dp) C1,S1,C2,S2,V,O,Z0,CPSI,SPSI
    integer eps1,eps2
    real(dp) dv
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(k%NOCAVITY.and.(.not.EL%always_on)) RETURN

!    IF(k%NOCAVITY) RETURN

        IF(I==1.AND.EL%P%KILL_ENT_FRINGE) RETURN
        IF(I==-1.AND.EL%P%KILL_EXI_FRINGE) RETURN
    eps1=1
    eps2=-1
    if(EL%P%DIR*I==1) then
       Z0=0.0_dp
       dv=0.0_dp
    else
       Z0=EL%L
       dv=EL%dvds*z0
    endif

    CPSI=COS(EL%PSI)
    SPSI=SIN(EL%PSI)

    O=EL%freq*twopi/CLIGHT
    C1=(eps1+(EL%P%DIR-eps1)*0.5_dp)*COS(O*(x(6)-Z0)+EL%PHAS+EL%phase0)
    C2=(eps2+(EL%P%DIR-eps2)*0.5_dp)*COS(O*(x(6)+Z0)+EL%PHAS+EL%phase0+EL%DPHAS)
    ! REMOVE FRINGE IN OPPOSITE DIRECTION  ULTRA RELATIVISTIC
    S1=(eps1+(EL%P%DIR-eps1)*0.5_dp)*SIN(O*(x(6)-Z0)+EL%PHAS+EL%phase0)
    S2=(eps2+(EL%P%DIR-eps2)*0.5_dp)*SIN(O*(x(6)+ Z0)+EL%PHAS+EL%phase0+EL%DPHAS)
    ! REMOVE FRINGE IN OPPOSITE DIRECTION   ULTRA RELATIVISTIC
    V=I*EL%P%CHARGE*(EL%volt-dv)*volt_c/EL%P%P0C

    X(2)=X(2)+V*(CPSI*S1+SPSI*S2)*X(1)
    X(4)=X(4)+V*(CPSI*S1+SPSI*S2)*X(3)
    x(5)=x(5)-0.5_dp*(X(1)**2+X(3)**2)*V*(CPSI*C1+SPSI*C2)*O

  END SUBROUTINE FRINGECAVR_TRAV

  SUBROUTINE FRINGECAVP_TRAV(EL,I,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(CAV_TRAVP),INTENT(INOUT):: EL
    integer, intent(in) :: i
    TYPE(REAL_8) C1,S1,C2,S2,V,O,Z0,F,CPSI,SPSI,dv
    integer eps1,eps2
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(k%NOCAVITY.and.(.not.EL%always_on)) RETURN   
!    IF(k%NOCAVITY) RETURN

        IF(I==1.AND.EL%P%KILL_ENT_FRINGE) RETURN
        IF(I==-1.AND.EL%P%KILL_EXI_FRINGE) RETURN

    CALL ALLOC(C1,S1,C2,S2,V,O,Z0,F,CPSI,SPSI)
    call alloc(dv)

    eps1=1
    eps2=-1
    if(EL%P%DIR*I==1) then
       Z0=0.0_dp
       dv=0.0_dp
    else
       Z0=EL%L
       dv=EL%dvds*z0
    endif

    CPSI=COS(EL%PSI)
    SPSI=SIN(EL%PSI)

    O=EL%freq*twopi/CLIGHT
    C1=(eps1+(EL%P%DIR-eps1)*0.5_dp)*COS(O*(x(6)-Z0)+EL%PHAS+EL%phase0)
    C2=(eps2+(EL%P%DIR-eps2)*0.5_dp)*COS(O*(x(6)+Z0)+EL%PHAS+EL%phase0+EL%DPHAS)
    ! REMOVE FRINGE IN OPPOSITE DIRECTION  ULTRA RELATIVISTIC
    S1=(eps1+(EL%P%DIR-eps1)*0.5_dp)*SIN(O*(x(6)-Z0)+EL%PHAS+EL%phase0)
    S2=(eps2+(EL%P%DIR-eps2)*0.5_dp)*SIN(O*(x(6)+Z0)+EL%PHAS+EL%phase0+EL%DPHAS)
    ! REMOVE FRINGE IN OPPOSITE DIRECTION   ULTRA RELATIVISTIC
    V=I*EL%P%CHARGE*(EL%volt-dv)*volt_c/EL%P%P0C


    X(2)=X(2)+V*(CPSI*S1+SPSI*S2)*X(1)
    X(4)=X(4)+V*(CPSI*S1+SPSI*S2)*X(3)
    x(5)=x(5)-0.5_dp*(X(1)**2+X(3)**2)*V*(CPSI*C1+SPSI*C2)*O




    call KILL(dv)
    CALL KILL(C1,S1,C2,S2,V,O,Z0,F,CPSI,SPSI)
  END SUBROUTINE FRINGECAVP_TRAV

  SUBROUTINE  FRINGE_CAV_TRAVR(EL,X,k,J)
    IMPLICIT NONE
    integer,INTENT(IN):: J
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(CAV_TRAV),INTENT(INOUT):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    ! J=1 front
    IF(J==1) THEN

       CALL FRINGECAV_TRAV(EL,EL%P%DIR,X,k)

    ELSE

       CALL FRINGECAV_TRAV(EL,-EL%P%DIR,X,k)

    ENDIF

  END SUBROUTINE FRINGE_CAV_TRAVR

  SUBROUTINE  FRINGE_CAV_TRAVP(EL,X,k,J)
    IMPLICIT NONE
    integer,INTENT(IN):: J
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(CAV_TRAVP),INTENT(INOUT):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    ! J=1 front
    IF(J==1) THEN

       CALL FRINGECAV_TRAV(EL,EL%P%DIR,X,k)

    ELSE

       CALL FRINGECAV_TRAV(EL,-EL%P%DIR,X,k)

    ENDIF

  END SUBROUTINE FRINGE_CAV_TRAVP



  SUBROUTINE ZEROR_CAV_TRAV(EL,I)
    IMPLICIT NONE
    TYPE(CAV_TRAV), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%DPHAS)) then
          deallocate(EL%PSI)
          deallocate(EL%DPHAS)
          deallocate(EL%DVDS)
          deallocate(EL%cavity_totalpath)
          deallocate(EL%phase0)
          deallocate(EL%always_on)
       endif
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%phase0)
       NULLIFY(EL%cavity_totalpath)
       NULLIFY(EL%PSI)
       NULLIFY(EL%DPHAS)
       NULLIFY(EL%DVDS)
       NULLIFY(EL%always_on)
    endif

  END SUBROUTINE ZEROR_CAV_TRAV

  SUBROUTINE ZEROP_CAV_TRAV(EL,I)
    IMPLICIT NONE
    TYPE(CAV_TRAVP), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%DPHAS)) then
          CALL KILL(EL%DPHAS)
          deallocate(EL%DPHAS)
          CALL KILL(EL%PSI)
          deallocate(EL%PSI)
          CALL KILL(EL%DVDS)
          deallocate(EL%DVDS)
          deallocate(EL%cavity_totalpath)
          deallocate(EL%phase0)
          deallocate(EL%always_on)
       endif
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%phase0)
       NULLIFY(EL%cavity_totalpath)
       NULLIFY(EL%PSI)
       NULLIFY(EL%DPHAS)
       NULLIFY(EL%DVDS)
       NULLIFY(EL%always_on)
    endif

  END SUBROUTINE ZEROP_CAV_TRAV


  SUBROUTINE ZEROr_mon(EL,I)
    IMPLICIT NONE
    TYPE(MON), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%x)) deallocate(EL%x)
       if(ASSOCIATED(EL%y)) deallocate(EL%y)

    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%x)
       NULLIFY(EL%y)

    endif


  END SUBROUTINE ZEROr_mon

  SUBROUTINE ZEROP_mon(EL,I)
    IMPLICIT NONE
    TYPE(MONP), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k,j
    IF(I==-1) THEN
       if(ASSOCIATED(EL%x)) deallocate(EL%x)
       if(ASSOCIATED(EL%y)) deallocate(EL%y)

    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%x)
       NULLIFY(EL%y)

    endif

  END SUBROUTINE ZEROP_mon

  SUBROUTINE ZEROr_RCOL(EL,I)
    IMPLICIT NONE
    TYPE(RCOL), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
     return
    IF(I==-1) THEN
     !  if(ASSOCIATED(EL%A)) THEN
     !     CALL KILL(EL%A)
     !     deallocate(EL%A)
     !  ENDIF

    elseif(i==0)       then          ! nullifies

     !  NULLIFY(EL%A)

    endif


  END SUBROUTINE ZEROr_RCOL

  SUBROUTINE ZEROP_RCOL(EL,I)
    IMPLICIT NONE
    TYPE(RCOLP), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k,j
    return 
   IF(I==-1) THEN
!       if(ASSOCIATED(EL%A)) THEN
!          CALL KILL(EL%A)
!          deallocate(EL%A)
!       ENDIF

    elseif(i==0)       then          ! nullifies

 !      NULLIFY(EL%A)

    endif

  END SUBROUTINE ZEROP_RCOL


  SUBROUTINE ZEROr_ECOL(EL,I)
    IMPLICIT NONE
    TYPE(ECOL), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
     return 
   IF(I==-1) THEN
  !     if(ASSOCIATED(EL%A)) THEN
  !        CALL KILL(EL%A)
  !        deallocate(EL%A)
  !     ENDIF

    elseif(i==0)       then          ! nullifies

   !    NULLIFY(EL%A)

    endif

  END SUBROUTINE ZEROr_ECOL

  SUBROUTINE ZEROP_ECOL(EL,I)
    IMPLICIT NONE
    TYPE(ECOLP), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k,j
    IF(I==-1) THEN
     !  if(ASSOCIATED(EL%A)) THEN
     !     CALL KILL(EL%A)
     !     deallocate(EL%A)
     !  ENDIF

    elseif(i==0)       then          ! nullifies

     !  NULLIFY(EL%A)

    endif

  END SUBROUTINE ZEROP_ECOL


  ! TYPE multip


  SUBROUTINE ZEROr_DKD2(EL,I)
    IMPLICIT NONE
    TYPE(DKD2), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%F)) deallocate(EL%F)
    elseif(i==0)       then          ! nullifies
       NULLIFY(EL%F)
    endif

  END SUBROUTINE ZEROr_DKD2

  SUBROUTINE ZEROp_DKD2(EL,I)
    IMPLICIT NONE
    TYPE(DKD2P), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k

    IF(I==-1) THEN
       if(ASSOCIATED(EL%F)) deallocate(EL%F)
    elseif(i==0)       then          ! nullifies
       NULLIFY(EL%F)
    endif
  END SUBROUTINE ZEROp_DKD2

  SUBROUTINE ZEROr_sol5(EL,I)
    IMPLICIT NONE
    TYPE(sol5), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN  !  Sadistic stuff
       if(ASSOCIATED(EL%dx)) deallocate(EL%dx)
       if(ASSOCIATED(EL%dy)) deallocate(EL%dy)
       if(ASSOCIATED(EL%pitch_x)) deallocate(EL%pitch_x)
       if(ASSOCIATED(EL%pitch_y)) deallocate(EL%pitch_y)
    elseif(i==0)       then          ! nullifies
       NULLIFY(EL%dx,EL%dy,EL%pitch_x,EL%pitch_y)
    endif

  END SUBROUTINE ZEROr_sol5

  SUBROUTINE ZEROp_sol5(EL,I)
    IMPLICIT NONE
    TYPE(sol5P), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN  !  Sadistic stuff
       if(ASSOCIATED(EL%dx)) deallocate(EL%dx)
       if(ASSOCIATED(EL%dy)) deallocate(EL%dy)
       if(ASSOCIATED(EL%pitch_x)) deallocate(EL%pitch_x)
       if(ASSOCIATED(EL%pitch_y)) deallocate(EL%pitch_y)
    elseif(i==0)       then          ! nullifies
       NULLIFY(EL%dx,EL%dy,EL%pitch_x,EL%pitch_y)
    endif
  END SUBROUTINE ZEROp_sol5

  SUBROUTINE ZEROr_KTK(EL,I)
    IMPLICIT NONE
    TYPE(KTK), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%MATX)) then
          deallocate(EL%MATX)
          deallocate(EL%LX)
       endif
       if(ASSOCIATED(EL%MATY)) then
          deallocate(EL%MATY)
          deallocate(EL%LY)
       endif

    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%MATX)
       NULLIFY(EL%MATY)
       NULLIFY(EL%LX)
       NULLIFY(EL%LY)
    endif

  END SUBROUTINE ZEROr_KTK

  SUBROUTINE ZEROP_KTK(EL,I)
    IMPLICIT NONE
    TYPE(KTKP), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k,j
    IF(I==-1) THEN
       if(ASSOCIATED(EL%MATX)) then
          deallocate(EL%MATX)
          deallocate(EL%LX)
       endif
       if(ASSOCIATED(EL%MATY)) then
          deallocate(EL%MATY)
          deallocate(EL%LY)
       endif

    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%MATX)
       NULLIFY(EL%MATY)
       NULLIFY(EL%LX)
       NULLIFY(EL%LY)

    endif

  END SUBROUTINE ZEROP_KTK

  SUBROUTINE ALLOCKTK(EL)
    IMPLICIT NONE
    TYPE(KTKP), INTENT(INOUT)::EL
    INTEGER I,J

    DO I=1,2
       DO J=1,3
          CALL ALLOC(EL%MATX(I,J))
          CALL ALLOC(EL%MATY(I,J))
       ENDDO
    ENDDO

    DO I=1,6
       CALL ALLOC(EL%LX(I))
    ENDDO
    DO I=1,3
       CALL ALLOC(EL%LY(I))
    ENDDO

  END SUBROUTINE ALLOCKTK

  SUBROUTINE KILLKTK(EL)
    IMPLICIT NONE
    TYPE(KTKP), INTENT(INOUT)::EL
    INTEGER I,J

    DO I=1,2
       DO J=1,3
          CALL KILL(EL%MATX(I,J))
          CALL KILL(EL%MATY(I,J))
       ENDDO
    ENDDO

    DO I=1,6
       CALL KILL(EL%LX(I))
    ENDDO
    DO I=1,3
       CALL KILL(EL%LY(I))
    ENDDO

  END SUBROUTINE KILLKTK

  SUBROUTINE ZEROr_TKT7(EL,I)
    IMPLICIT NONE
    TYPE(TKTF), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%F)) deallocate(EL%F)
       if(ASSOCIATED(EL%MATX)) then
          deallocate(EL%MATX)
       endif
       if(ASSOCIATED(EL%MATY)) then
          deallocate(EL%MATY)
       endif
       if(ASSOCIATED(EL%LX)) then
          deallocate(EL%LX)
       endif
       if(ASSOCIATED(EL%RMATX)) then
          deallocate(EL%RMATX)
       endif
       if(ASSOCIATED(EL%RMATY)) then
          deallocate(EL%RMATY)
       endif
       if(ASSOCIATED(EL%RLX)) then
          deallocate(EL%RLX)
       endif
       !       if(ASSOCIATED(EL%dx)) then
       !          deallocate(EL%dx)
       !       endif
       !       if(ASSOCIATED(EL%dy)) then
       !          deallocate(EL%dy)
       !       endif
    elseif(i==0)       then          ! nullifies

       !       NULLIFY(EL%dx)
       !       NULLIFY(EL%dy)
       NULLIFY(EL%F)
       NULLIFY(EL%MATX)
       NULLIFY(EL%MATY)
       NULLIFY(EL%LX)
       NULLIFY(EL%RMATX)
       NULLIFY(EL%RMATY)
       NULLIFY(EL%RLX)
    endif

  END SUBROUTINE ZEROr_TKT7

  SUBROUTINE ZEROP_TKT7(EL,I)
    IMPLICIT NONE
    TYPE(TKTFP), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    integer k,j

    IF(I==-1) THEN
       if(ASSOCIATED(EL%F)) deallocate(EL%F)
       if(ASSOCIATED(EL%MATX)) then
          DO K=1,2
             DO J=1,3
                CALL KILL(EL%MATX(K,J))   ! not used, will be used locally only
             ENDDO
          ENDDO
          deallocate(EL%MATX)
       endif
       if(ASSOCIATED(EL%MATY)) then
          DO K=1,2
             DO J=1,3
                CALL KILL(EL%MATY(K,J))   ! not used, will be used locally only
             ENDDO
          ENDDO
          deallocate(EL%MATY)
       endif

       if(ASSOCIATED(EL%LX)) then
          DO J=1,3
             CALL KILL(EL%LX(J))   ! not used, will be used locally only
          ENDDO
          deallocate(EL%LX)
       endif
       if(ASSOCIATED(EL%RMATX)) then
          DO K=1,2
             DO J=1,3
                CALL KILL(EL%RMATX(K,J))   ! not used, will be used locally only
             ENDDO
          ENDDO
          deallocate(EL%RMATX)
       endif
       if(ASSOCIATED(EL%RMATY)) then
          DO K=1,2
             DO J=1,3
                CALL KILL(EL%RMATY(K,J))   ! not used, will be used locally only
             ENDDO
          ENDDO
          deallocate(EL%RMATY)
       endif

       if(ASSOCIATED(EL%RLX)) then
          DO J=1,3
             CALL KILL(EL%RLX(J))   ! not used, will be used locally only
          ENDDO
          deallocate(EL%RLX)
       endif
       !       if(ASSOCIATED(EL%dx)) then
       !          deallocate(EL%dx)
       !       endif
       !       if(ASSOCIATED(EL%dy)) then
       !          deallocate(EL%dy)
       !       endif

    elseif(i==0)       then          ! nullifies

       !       NULLIFY(EL%dx)
       !       NULLIFY(EL%dy)
       NULLIFY(EL%MATX)
       NULLIFY(EL%MATY)
       NULLIFY(EL%LX)
       NULLIFY(EL%RMATX)
       NULLIFY(EL%RMATY)
       NULLIFY(EL%RLX)

    endif

  END SUBROUTINE ZEROP_TKT7

  SUBROUTINE ALLOCTKT7(EL)
    IMPLICIT NONE
    TYPE(TKTFP), INTENT(INOUT)::EL
    INTEGER I,J

    DO I=1,2
       DO J=1,3
          CALL ALLOC(EL%MATX(I,J))
          CALL ALLOC(EL%MATY(I,J))
          CALL ALLOC(EL%RMATX(I,J))
          CALL ALLOC(EL%RMATY(I,J))
       ENDDO
    ENDDO

    DO I=1,3
       CALL ALLOC(EL%LX(I))
       CALL ALLOC(EL%RLX(I))
    ENDDO

  END SUBROUTINE ALLOCTKT7

  SUBROUTINE KILLTKT7(EL)
    IMPLICIT NONE
    TYPE(TKTFP), INTENT(INOUT)::EL
    INTEGER I,J

    DO I=1,2
       DO J=1,3
          CALL KILL(EL%MATX(I,J))
          CALL KILL(EL%MATY(I,J))
          CALL KILL(EL%RMATX(I,J))
          CALL KILL(EL%RMATY(I,J))
       ENDDO
    ENDDO
    DO I=1,3
       CALL KILL(EL%LX(I))
       CALL KILL(EL%RLX(I))
    ENDDO

  END SUBROUTINE KILLTKT7




!       if(ASSOCIATED(EL%bf_x)) then
!          CALL KILL(EL%bf_x,S_B0%N_MONO)   ! not used, will be used locally only
!          deallocate(EL%bf_x)
!       endif
!       if(ASSOCIATED(EL%bf_Y)) then
!          CALL KILL(EL%bf_Y,S_B0%N_MONO)   ! not used, will be used locally only
!          deallocate(EL%bf_Y)
!       endif


SUBROUTINE ZEROr_teapot(EL,I)
    IMPLICIT NONE
    TYPE(TEAPOT), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%F)) deallocate(EL%F)
       if(ASSOCIATED(EL%bf_x)) then
          deallocate(EL%bf_x)
       endif
       if(ASSOCIATED(EL%bf_y)) then
          deallocate(EL%bf_y)
       endif
       if(ASSOCIATED(EL%DRIFTKICK)) then
          deallocate(EL%DRIFTKICK)
       endif
       if(ASSOCIATED(EL%e_x)) then
         deallocate(EL%e_x,EL%e_y,EL%PHI,EL%AE,EL%BE,el%vm)
       endif
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%f)
       NULLIFY(EL%bf_x)
       NULLIFY(EL%bf_y)
       NULLIFY(EL%DRIFTKICK)
       NULLIFY(EL%e_x,EL%e_y,EL%PHI,EL%AE,EL%BE,el%vm)
    endif

  END SUBROUTINE ZEROr_teapot

  SUBROUTINE ZEROP_teapot(EL,I)
    IMPLICIT NONE
    TYPE(TEAPOTP), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I

    IF(I==-1) THEN
       if(ASSOCIATED(EL%F)) deallocate(EL%F)
       if(ASSOCIATED(EL%bf_x)) then
          CALL KILL(EL%bf_x,S_B_FROM_V%N_MONO)   ! not used, will be used locally only
          !          CALL KILL(EL%bf_x,S_B(EL%P%NMUL)%N_MONO)   ! not used, will be used locally only
          deallocate(EL%bf_x)
       endif
       if(ASSOCIATED(EL%bf_Y)) then
          CALL KILL(EL%bf_Y,S_B_FROM_V%N_MONO)   ! not used, will be used locally only
          !          CALL KILL(EL%bf_Y,S_B(EL%P%NMUL)%N_MONO)   ! not used, will be used locally only
          deallocate(EL%bf_Y)
       endif
       if(ASSOCIATED(EL%DRIFTKICK)) then
          deallocate(EL%DRIFTKICK)
       endif
       if(ASSOCIATED(EL%e_x)) then
         CALL KILL(EL%e_x,S_E%N_MONO)
         CALL KILL(EL%e_y,S_E%N_MONO)
         CALL KILL(EL%PHI,S_E%N_MONO)
         CALL KILL(EL%VM,S_E%N_MONO)
         CALL KILL(EL%AE)
         CALL KILL(EL%BE)
         deallocate(EL%e_x,EL%e_y,EL%AE,EL%BE,EL%PHI,el%vm)
       endif

    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%f)
       NULLIFY(EL%bf_x)
       NULLIFY(EL%bf_Y)
       NULLIFY(EL%DRIFTKICK)
       NULLIFY(EL%e_x,EL%e_y,EL%AE,EL%BE,EL%PHI,EL%VM)

    endif

  END SUBROUTINE ZEROP_teapot


  SUBROUTINE ZEROR_CAV4(EL,I)
    IMPLICIT NONE
    TYPE(CAV4), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%N_BESSEL)) then
          deallocate(EL%N_BESSEL)
       endif
       if(ASSOCIATED(EL%t)) then
          deallocate(EL%t)
       endif
       if(ASSOCIATED(EL%NF)) then
          deallocate(EL%NF)
       endif
       if(ASSOCIATED(EL%F)) then
          deallocate(EL%F)
       endif
       if(ASSOCIATED(EL%PH)) then
          deallocate(EL%PH)
       endif
       if(ASSOCIATED(EL%A)) then
          deallocate(EL%A)
       endif
       if(ASSOCIATED(EL%R)) then
          deallocate(EL%R)
       endif
       if(ASSOCIATED(EL%always_on)) then
          deallocate(EL%always_on)
       endif

       if(ASSOCIATED(EL%CAVITY_TOTALPATH)) then
          deallocate(EL%CAVITY_TOTALPATH)
       endif
       if(ASSOCIATED(EL%phase0)) then
          deallocate(EL%phase0)
       endif
       if(ASSOCIATED(EL%ACC)) then
       call kill_acceleration(EL%ACC)
          deallocate(EL%ACC)
       endif
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%ACC)
       NULLIFY(EL%t)
       NULLIFY(EL%phase0)
       NULLIFY(EL%CAVITY_TOTALPATH)
       NULLIFY(EL%N_BESSEL)
       NULLIFY(EL%NF)
       NULLIFY(EL%F)
       NULLIFY(EL%A)
       NULLIFY(EL%R)
       NULLIFY(EL%always_on)
       NULLIFY(EL%PH)
    endif

  END SUBROUTINE ZEROR_CAV4

  SUBROUTINE ZEROP_CAV4(EL,I)
    IMPLICIT NONE
    TYPE(CAV4P), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%t)) then
          deallocate(EL%t)
       endif
       if(ASSOCIATED(EL%N_BESSEL)) then
          deallocate(EL%N_BESSEL)
       endif
       if(ASSOCIATED(EL%CAVITY_TOTALPATH)) then
          deallocate(EL%CAVITY_TOTALPATH)
       endif
       if(ASSOCIATED(EL%phase0)) then
          deallocate(EL%phase0)
       endif
       if(ASSOCIATED(EL%F)) then
          CALL KILL(EL%F,EL%NF)
          deallocate(EL%F)
       endif
       if(ASSOCIATED(EL%PH)) then
          CALL KILL(EL%PH,EL%NF)
          deallocate(EL%PH)
       endif
       if(ASSOCIATED(EL%R)) then
          CALL KILL(EL%R)
          deallocate(EL%R)
       endif
       if(ASSOCIATED(EL%always_on)) then
          deallocate(EL%always_on)
       endif
       if(ASSOCIATED(EL%A)) then
          CALL KILL(EL%A)
          deallocate(EL%A)
       endif
       if(ASSOCIATED(EL%NF)) then
          deallocate(EL%NF)
       endif
       if(ASSOCIATED(EL%ACC)) then
       call kill_acceleration(EL%ACC)
          deallocate(EL%ACC)
       endif
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%ACC)
       NULLIFY(EL%t)
       NULLIFY(EL%phase0)
       NULLIFY(EL%CAVITY_TOTALPATH)
       NULLIFY(EL%N_BESSEL)
       NULLIFY(EL%NF)
       NULLIFY(EL%F)
       NULLIFY(EL%A)
       NULLIFY(EL%R)
       NULLIFY(EL%always_on)
       NULLIFY(EL%PH)
    endif

  END SUBROUTINE ZEROP_CAV4

 SUBROUTINE ZEROR_superdrift(EL,I)
    IMPLICIT NONE
    TYPE(SUPERDRIFT1), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN

       if(ASSOCIATED(EL%A_X1)) then
       deallocate(EL%A_X1)
       deallocate(EL%A_X2)
       deallocate(EL%A_D)
       deallocate(EL%A_ANG)
       deallocate(EL%ENERGY)
       deallocate(EL%TIME)
       deallocate(EL%A_T)
       deallocate(EL%p0b)
       deallocate(EL%b0b)
       endif
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%A_X1)
       NULLIFY(EL%A_X2)
       NULLIFY(EL%A_D)
       NULLIFY(EL%A_ANG)
       NULLIFY(EL%ENERGY)
       NULLIFY(EL%TIME)
       NULLIFY(EL%A_T)
       NULLIFY(EL%p0b)
       NULLIFY(EL%b0b)
    endif

  END SUBROUTINE ZEROR_superdrift

 SUBROUTINE ZEROp_superdrift(EL,I)
    IMPLICIT NONE
    TYPE(SUPERDRIFT1p), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN

       if(ASSOCIATED(EL%A_X1)) then
       deallocate(EL%A_X1)
       deallocate(EL%A_X2)
       deallocate(EL%A_D)
       deallocate(EL%A_ANG)
       deallocate(EL%ENERGY)
       deallocate(EL%TIME)
       deallocate(EL%A_T)
       deallocate(EL%p0b)
       deallocate(EL%b0b)
       endif
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%A_X1)
       NULLIFY(EL%A_X2)
       NULLIFY(EL%A_D)
       NULLIFY(EL%A_ANG)
       NULLIFY(EL%ENERGY)
       NULLIFY(EL%TIME)
       NULLIFY(EL%A_T)
       NULLIFY(EL%p0b)
       NULLIFY(EL%b0b)
    endif

  END SUBROUTINE ZEROp_superdrift


  SUBROUTINE ZEROR_RAMP(EL,I)
    IMPLICIT NONE
    TYPE(RAMPING), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
     call kill_ramping(EL)
    elseif(i==0)       then          ! nullifies

     call nullify_ramping(EL)

    endif

  END SUBROUTINE ZEROR_RAMP



!!!!!!!!!!!!!!!!! cav4 acceleration !!!!!!!!!!!!!!!!!!! 
   SUBROUTINE alloc_acceleration(acc,nst,n,n_max,filename)
   implicit none
   type(acceleration), target :: acc
   integer i,n,n_max,nst
   character(*) filename
   allocate(acc%n)
   acc%n=n
   allocate(acc%tableau(n))
   allocate(acc%fichier)
   allocate(acc%r)
!   allocate(acc%unit_time)
   allocate(acc%w1)
   allocate(acc%nst)
   allocate(acc%de(nst))
   allocate(acc%e_in(nst))
   allocate(acc%w2)
   allocate(acc%pos)
   nullify(acc%next)
   acc%de=0.0_dp
   acc%e_in=0.0_dp
   acc%nst=nst
   acc%pos=0
!   acc%w1=0   not yet defined, done later
!   acc%w2=0
   acc%r=1.0_dp
   acc%fichier=' '
   
   if(len(filename)>255) then
    write(6,*)  " Name of file too long (>255) "
    stop 1945
   endif 
   acc%fichier=filename
   
   do i=1,n
    call alloc_tableau(acc%tableau(i),n_max)
   enddo
   
   end SUBROUTINE alloc_acceleration
   
   SUBROUTINE alloc_tableau(tableau,n)
   implicit none
   type(temps_energie), target, intent(inout) :: tableau
   integer n
   allocate(tableau%volt(n),tableau%phase(n),tableau%temps,tableau%energie,tableau%tc)
    tableau%volt=0.0_dp
    tableau%phase=0.0_dp
    tableau%temps=0.0_dp
    tableau%energie=0.0_dp
    tableau%tc=0.0_dp
   end SUBROUTINE alloc_tableau
 
   SUBROUTINE kill_tableau(tableau)
   implicit none
   type(temps_energie), target, intent(inout)  :: tableau
   deallocate(tableau%volt,tableau%phase,tableau%temps,tableau%energie,tableau%tc)

   end SUBROUTINE kill_tableau
 
   SUBROUTINE kill_acceleration(acc)
   implicit none
   type(acceleration), target , intent(inout) :: acc
   integer i
   
   do i=1,acc%n
    call kill_tableau(acc%tableau(i))
   enddo
   
   deallocate(acc%tableau)
   nullify(acc%next)
   nullify(acc%previous)
   deallocate(acc%pos)
!   deallocate(acc%unit_time)
   deallocate(acc%n)
   deallocate(acc%r)
   deallocate(acc%w1)
   deallocate(acc%w2)
   deallocate(acc%de)
   deallocate(acc%e_in)
   deallocate(acc%nst)
   deallocate(acc%fichier)
   
   end SUBROUTINE kill_acceleration

   SUBROUTINE nullify_acceleration(acc)
   implicit none
   type(acceleration), target , intent(inout) :: acc
   
   nullify(acc%w1)
   nullify(acc%w2)
   nullify(acc%r)
   nullify(acc%n)
   nullify(acc%POS)
   nullify(acc%NEXT)
   nullify(acc%previous)
!   nullify(acc%unit_time)
   nullify(acc%nst)
   nullify(acc%de)
   nullify(acc%e_in)
   nullify(acc%tableau)
   nullify(acc%fichier)
   
   end SUBROUTINE nullify_acceleration

   SUBROUTINE copy_tableau(tableau1,tableau2)
   implicit none
   type(temps_energie), target, intent(in) :: tableau1
   type(temps_energie), target,  intent(inout)  :: tableau2

    if(associated(tableau2%volt)) call kill_tableau(tableau2)
    call alloc_tableau(tableau2,size(tableau1%phase))
    
    tableau2%volt=tableau1%volt
    tableau2%phase=tableau1%phase
    tableau2%temps=tableau1%temps
    tableau2%energie=tableau1%energie
    tableau2%tc=tableau1%tc
   end SUBROUTINE copy_tableau
 
   SUBROUTINE copy_acceleration(acc1,acc2)
   implicit none
   type(acceleration), target, intent(in) :: acc1
   type(acceleration), target,  intent(inout)  :: acc2
   integer i
   
   if(associated(acc2%n)) call kill_acceleration(acc2)
   call alloc_acceleration(acc2,acc1%nst,size(acc1%tableau),size(acc1%tableau(1)%volt),acc1%fichier)
   acc2%previous=>acc1%previous
   acc2%next=>acc1%next
   acc2%pos=acc1%pos
   acc2%nst=acc1%nst
   acc2%de=acc1%de
   acc2%e_in=acc1%e_in
!   acc2%unit_time=acc1%unit_time
   acc2%r=acc1%r
   do i=1,acc2%n
!    acc2%tableau(i)=acc1%tableau(i)
    call copy_tableau(acc1%tableau(i),acc2%tableau(i))
   enddo
   

   end SUBROUTINE copy_acceleration
 

   SUBROUTINE lecture_fichier(EL,fichier)
   ! code for cavity   
   implicit none
   type(element), target, intent(inout) :: EL
   type(elementp), pointer :: elp
   character(*) fichier
   integer mf,i,n_mode,n_max,j,n,cavpath,pos
   integer, allocatable :: js(:)
   real(dp) r,ut,tc,dtimen,dtimeb
   
   if(ASSOCIATED(ACC)) THEN
    ACC%NEXT=>el%parent_fibre
    pos=acc%pos+1
   else
   pos=1
   paccfirst=>el%parent_fibre
   ENDIF
   
   if(el%kind/=kind4) then
    write(6,*) " error not a standard cavity "
    stop 1946
   endif
   
   call kanalnummer(mf,fichier)
   read(mf,*) n,ut,r,cavpath,n_mode   ! r percentage of acceleration from that cavity
  ! n is number of lines in files
  ! r is the percentage of acceleration done by that cavity
  ! cavpath is 0 or 1  usual fake pill box parameter
  ! n_mode number of mode

   allocate(js(n_mode))
   
   allocate(el%c4%acc)
   
   acc=> el%c4%acc
   
      if(.not.ASSOCIATED(paccfirst,el%parent_fibre)) THEN
      acc%previous=>paccthen
      else
      accfirst=>acc
      endif
   
   read(mf,*) js

   n_max=0
   do i=1,n_mode
    if(js(i)>n_max) n_max=js(i)
   enddo


   
   call alloc_acceleration(acc,el%p%nst,n,n_max,fichier)
   

!    acc%unit_time=ut

   
   acc%pos=pos
   acc%r=r
   do i=1,acc%n
    if(read_tc) then
     read(mf,*) acc%tableau(i)%temps,acc%tableau(i)%energie,   &
     (acc%tableau(i)%volt(js(j)),acc%tableau(i)%phase(js(j)),j=1,n_mode ),acc%tableau(i)%tc
    else
     read(mf,*) acc%tableau(i)%temps,acc%tableau(i)%energie,   &
     (acc%tableau(i)%volt(js(j)),acc%tableau(i)%phase(js(j)),j=1,n_mode )
     acc%tableau(i)%tc=0.0_dp
    endif 
     acc%tableau(i)%temps=acc%tableau(i)%temps*ut
    if(i==1) then
      dtimen=0
      dtimeb=0
    else
     dtimen=acc%tableau(i)%temps-acc%tableau(i-1)%temps
     if(i>2) then
       if(abs((dtimeb-dtimen)/(acc%tableau(1)%temps+acc%tableau(2)%temps))>1.d-10) then
        Write(6,*) " Time table for cavity is not made equidistant times "
        write(6,*) " please fix file : ",fichier(1:len_trim(fichier))
        stop
       endif
        dtimeb=acc%tableau(i)%temps-acc%tableau(i-1)%temps
      else
       if(i==2) then
        dtimeb=acc%tableau(2)%temps-acc%tableau(1)%temps
       endif
     endif
    endif

  !  acc%tableau(i)%phase(2)=-acc%tableau(i)%phase(2)
  !  write(6,*) acc%tableau(i)%phase(2)

   enddo
   
   close(mf)
   
   deallocate(js)
   elp=>el%parent_fibre%magp
   if(.not.associated(elp%c4%acc)) then
    allocate(elp%c4%acc)
      call nullify_acceleration(elp%c4%acc)
   endif

     ! write(6,*) " initial time shift in cavity ",el%c4%t
      tc=0.0_dp   !el%c4%t
      call copy_acceleration(acc,elp%c4%acc)

      if(size(acc%tableau(1)%volt)/=el%c4%nf) then
       el%c4%nf=size(acc%tableau(1)%volt)
       elp%c4%nf=size(acc%tableau(1)%volt)
       call kill(elp%c4%f)
       deallocate(elp%c4%f)
       deallocate(el%c4%f)
       allocate(el%c4%f(el%c4%nf));el%c4%f=0.0_dp;el%c4%f(1)=1.0_dp;
       allocate(elp%c4%f(el%c4%nf))
       call alloc(elp%c4%f,el%c4%nf)
       elp%c4%f(1)=1.0_dp    

       call kill(elp%c4%ph)
       deallocate(elp%c4%ph)
       deallocate(el%c4%ph)
       allocate(el%c4%ph(el%c4%nf));el%c4%ph=0.0_dp; 
       allocate(elp%c4%ph(el%c4%nf))
       call alloc(elp%c4%ph,el%c4%nf)
      endif
      
      el%c4%volt =1.0_dp
      elp%c4%volt =1.0_dp
      el%c4%phas  =0.0_dp
      elp%c4%phas =0.0_dp
      el%c4%phase0  =0.0_dp
      elp%c4%phase0 =0.0_dp      
      el%c4%t  =tc
      elp%c4%t =tc
     
         do i=1,el%c4%nf
          el%c4%f(i)   = acc%tableau(1)%volt(i)
          el%c4%ph(i)  = acc%tableau(1)%phase(i)
          elp%c4%f(i)  = acc%tableau(1)%volt(i)
          elp%c4%ph(i) = acc%tableau(1)%phase(i)
         enddo
     if(cavpath==0.or. cavpath==1) then   
     el%c4%cavity_totalpath=cavpath    
     elp%c4%cavity_totalpath=cavpath 
     else
     write(6,*) "cavpath is wrong ",cavpath  
     endif  
    
     NULLIFY(ACC%NEXT) 
     
     paccthen=>el%parent_fibre
     
   END SUBROUTINE lecture_fichier 
 
 !!!!!!!!!!!!! ramping !!!!!!!!!!!!! 
 
 !  SUBROUTINE alloc_ramping(acc,unit_time,t_max,n,n_max,filename)
  SUBROUTINE alloc_ramping(acc,t_max,n,n_max,filename)
   implicit none
   type(ramping), target :: acc
   integer i,n,n_max
   character(*) filename
   real(dp) t_max   !unit_time,
   
   allocate(acc%n)
   acc%n=n
   allocate(acc%table(0:n))
   allocate(acc%file)
   allocate(acc%r,acc%t_max)
!   allocate(acc%unit_time)
   acc%r=1.0_dp
   acc%t_max=t_max
!   acc%unit_time=unit_time
   acc%file=' '
   
   if(len(filename)>255) then
    write(6,*)  " Name of file too long (>255) "
    stop 1945
   endif 
   acc%file=filename
   
   do i=0,n
    call alloc_table(acc%table(i),n_max)
   enddo
   
   end SUBROUTINE alloc_ramping
   
   SUBROUTINE alloc_table(tableau,n)
   implicit none
   type(time_energy), target, intent(inout) :: tableau
   integer n
   allocate(tableau%an(n),tableau%bn(n),tableau%time,tableau%energy,tableau%b_t)
    tableau%an=0.0_dp
    tableau%bn=0.0_dp
    tableau%time=0.0_dp
    tableau%energy=0.0_dp
    tableau%b_t=0.0_dp
   end SUBROUTINE alloc_table 
 
   SUBROUTINE kill_table(tableau)
   implicit none
   type(time_energy), target, intent(inout)  :: tableau
   deallocate(tableau%an,tableau%bn,tableau%time,tableau%energy,tableau%b_t)

   end SUBROUTINE kill_table
 
   SUBROUTINE kill_ramping(acc)
   implicit none
   type(ramping), target , intent(inout) :: acc
   integer i
   
   do i=0,acc%n
    call kill_table(acc%table(i))
   enddo
   
   deallocate(acc%table)
   deallocate(acc%n)
   deallocate(acc%r)
   deallocate(acc%t_max)
!   deallocate(acc%unit_time)
   deallocate(acc%file)
   
   end SUBROUTINE kill_ramping
!!!!!!!!!!!!!!!!! cav4 acceleration !!!!!!!!!!!!!!!!!!! 
!  TYPE time_energy
!     real(dp),pointer :: time
!     real(dp),pointer :: energy
!     real(dp),pointer :: an(:),bn(:)
!  END TYPE time_energy
  
!  TYPE ramping
!     integer,pointer :: n 
!     real(dp), pointer :: r, unit_time 
!     type(time_energy),pointer :: table(:)
!     character(255), pointer :: file
!  END TYPE ramping

!!!!!!!!!!!!!!!!! cav4 acceleration !!!!!!!!!!!!!!!!!!! 

   SUBROUTINE nullify_ramping(acc)
   implicit none
   type(ramping), target , intent(inout) :: acc
   
   nullify(acc%r)
   nullify(acc%n)
   nullify(acc%file)
   nullify(acc%table)
!   nullify(acc%unit_time)
   
   
   end SUBROUTINE nullify_ramping

   SUBROUTINE copy_table(tableau1,tableau2)
   implicit none
   type(time_energy), target, intent(in) :: tableau1
   type(time_energy), target,  intent(inout)  :: tableau2

    if(associated(tableau2%an)) call kill_table(tableau2)
    call alloc_table(tableau2,size(tableau1%an))
    
    tableau2%an=tableau1%an
    tableau2%bn=tableau1%bn
    tableau2%time=tableau1%time
    tableau2%energy=tableau1%energy
    tableau2%b_t=tableau1%b_t
   end SUBROUTINE copy_table
 
   SUBROUTINE copy_ramping(acc1,acc2)
   implicit none
   type(ramping), target, intent(in) :: acc1
   type(ramping), target,  intent(inout)  :: acc2
   integer i
   
   if(associated(acc2%n)) call kill_ramping(acc2)
   call alloc_ramping(acc2,acc1%t_max,acc1%n,size(acc1%table(1)%an),acc1%file)
!   call alloc_ramping(acc2,acc1%unit_time,acc1%t_max,acc1%n,size(acc1%table(1)%an),acc1%file)
   
   do i=0,acc2%n
!    acc2%tableau(i)=acc1%tableau(i)
    call copy_table(acc1%table(i),acc2%table(i))
   enddo
   

   end SUBROUTINE copy_ramping
 

   SUBROUTINE reading_file(EL,fichier)
   ! code for ramping
   implicit none
   type(element), target, intent(inout) :: EL
   type(elementp), pointer :: elp
   type(ramping), pointer :: acc
   character(*) fichier
   integer mf,i,n_mode,n_max,j,n,cavpath,pos,np
   integer, allocatable :: js(:)
   real(dp) ut,dtimen,dtimeb
   character(255) line
   character(7) car
   logical timepatch
   timepatch=.false.


   np=1
   
   call kanalnummer(mf,fichier)
   read(mf,'(a255)') line
    if(index(line,"#")/=0) then
     read(line,*) n,ut,n_mode,car,np
    else
     read(line,*) n,ut,n_mode
    endif
    if(index(line,"T")/=0.or.index(line,"t")/=0) timepatch=.true.
!   read(mf,*) n,unit_time,n_mode
  ! write(6,*) n,r,cavpath,n_mode
   allocate(js(n_mode))
   
   allocate(el%ramp)
   
   acc=> el%ramp
   read(mf,*) js

   n_max=0
   do i=1,n_mode
    if(js(i)>n_max) n_max=js(i)
   enddo
   
   if(n_max<el%p%nmul) n_max = el%p%nmul
   if(el%kind==kind15) n_max=2
!   call alloc_ramping(acc,unit_time,0.0_dp,n,n_max,fichier)
   call alloc_ramping(acc,0.0_dp,n,n_max,fichier)
   acc%r=1.0_dp
   do i=1,acc%n
    if(timepatch) then
     read(mf,*) acc%table(i)%time,   &
     (acc%table(i)%bn(js(j)),acc%table(i)%an(js(j)),j=1,n_mode ),acc%table(i)%b_t
    else
     read(mf,*) acc%table(i)%time,   &
     (acc%table(i)%bn(js(j)),acc%table(i)%an(js(j)),j=1,n_mode )
        acc%table(i)%b_t=0.0_dp
    endif
    acc%table(i)%time=acc%table(i)%time*ut    
    if(i==1) then
      dtimen=0
      dtimeb=0
    else
     dtimen=acc%table(i)%time-acc%table(i-1)%time
     if(i>2) then
       if(abs((dtimeb-dtimen)/(acc%table(1)%time+acc%table(2)%time))>1.d-10) then
        Write(6,*) " Time table for ramping is not made equidistant times "
        write(6,*) " please fix file : ",fichier(1:len_trim(fichier))
        stop
       endif
        dtimeb=acc%table(i)%time-acc%table(i-1)%time
      else
       if(i==2) then
        dtimeb=acc%table(2)%time-acc%table(1)%time
       endif
     endif
    endif
     

    acc%table(i)%energy=0.d0

   enddo
   
   close(mf)
    acc%t_max= acc%table(1)%time+np*(acc%table(acc%n)%time-acc%table(1)%time)

   deallocate(js)
   elp=>el%parent_fibre%magp
   if(.not.associated(elp%ramp)) then
    allocate(elp%ramp)
      call nullify_ramping(elp%ramp)
   endif
      call copy_ramping(acc,elp%ramp)


   END SUBROUTINE reading_file 

!!!!!! !!!!!! end ramping !!!!!! !!!!!!

  SUBROUTINE ZEROR_KICKT3(EL,I)
    IMPLICIT NONE
    TYPE(KICKT3), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%thin_h_foc)) then
          deallocate(EL%hf)
          deallocate(EL%vf)
          deallocate(EL%thin_h_foc)
          deallocate(EL%thin_v_foc)
          deallocate(EL%thin_h_angle)
          deallocate(EL%thin_v_angle)
          deallocate(EL%ls)
          deallocate(EL%patch)
       if(ASSOCIATED(EL%dx)) deallocate(EL%dx)    ! sadistic stuff
       if(ASSOCIATED(EL%dy)) deallocate(EL%dy)
       if(ASSOCIATED(EL%pitch_x)) deallocate(EL%pitch_x)
       if(ASSOCIATED(EL%pitch_y)) deallocate(EL%pitch_y)
       endif
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%hf)
       NULLIFY(EL%vf)
       NULLIFY(EL%thin_h_foc)
       NULLIFY(EL%thin_v_foc)
       NULLIFY(EL%thin_h_angle)
       NULLIFY(EL%ls)
       NULLIFY(EL%thin_v_angle)
       NULLIFY(EL%patch)
       NULLIFY(EL%dx,EL%dy,EL%pitch_x,EL%pitch_y)
    endif

  END SUBROUTINE ZEROR_KICKT3

  SUBROUTINE ZEROP_KICKT3(EL,I)
    IMPLICIT NONE
    TYPE(KICKT3P), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%thin_h_foc)) then
          CALL KILL(EL%hf)
          CALL KILL(EL%vf)
          CALL KILL(EL%thin_h_foc)
          CALL KILL(EL%thin_v_foc)
          CALL KILL(EL%thin_h_angle)
          CALL KILL(EL%thin_v_angle)

          deallocate(EL%hf)
          deallocate(EL%vf)
          deallocate(EL%thin_h_foc)
          deallocate(EL%thin_v_foc)
          deallocate(EL%thin_h_angle)
          deallocate(EL%thin_v_angle)
          deallocate(EL%patch)
          deallocate(EL%ls)
       if(ASSOCIATED(EL%dx)) deallocate(EL%dx)
       if(ASSOCIATED(EL%dy)) deallocate(EL%dy)
       if(ASSOCIATED(EL%pitch_x)) deallocate(EL%pitch_x)
       if(ASSOCIATED(EL%pitch_y)) deallocate(EL%pitch_y)
       endif
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%hf)
       NULLIFY(EL%vf)
       NULLIFY(EL%thin_h_foc)
       NULLIFY(EL%thin_v_foc)
       NULLIFY(EL%thin_h_angle)
       NULLIFY(EL%thin_v_angle)
       NULLIFY(EL%patch)
       NULLIFY(EL%ls)
       NULLIFY(EL%dx,EL%dy,EL%pitch_x,EL%pitch_y)
    endif

  END SUBROUTINE ZEROP_KICKT3


  SUBROUTINE ZEROr_STREX(EL,I)
    IMPLICIT NONE
    TYPE(STREX), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%DRIFTKICK)) then
          deallocate(EL%DRIFTKICK)
       endif
       if(ASSOCIATED(EL%LIKEMAD)) then
          deallocate(EL%LIKEMAD)
       endif
       if(ASSOCIATED(EL%F)) deallocate(EL%F)
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%F)
       NULLIFY(EL%DRIFTKICK)
       NULLIFY(EL%LIKEMAD)
    endif

  END SUBROUTINE ZEROr_STREX

  SUBROUTINE ZEROP_STREX(EL,I)
    IMPLICIT NONE
    TYPE(STREXP), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%DRIFTKICK)) then
          deallocate(EL%DRIFTKICK)
       endif
       if(ASSOCIATED(EL%LIKEMAD)) then
          deallocate(EL%LIKEMAD)
       endif
       if(ASSOCIATED(EL%F)) deallocate(EL%F)
       NULLIFY(EL%LIKEMAD)
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%F)
       NULLIFY(EL%DRIFTKICK)
    endif

  END SUBROUTINE ZEROP_STREX


  SUBROUTINE ALLOCTEAPOT(EL)
    IMPLICIT NONE
    TYPE(TEAPOTP), INTENT(INOUT)::EL

   !  IF(EL%ELECTRIC) THEN
        call alloc(EL%E_X,S_E%N_MONO)
        call alloc(EL%E_Y,S_E%N_MONO)
        call alloc(EL%PHI,S_E%N_MONO)
        call alloc(EL%AE,SECTOR_NMUL_max);call alloc(EL%BE,SECTOR_NMUL_max);
   !  endif
        CALL ALLOC(EL%bf_x,S_B_FROM_V%N_MONO)
        CALL ALLOC(EL%bf_Y,S_B_FROM_V%N_MONO)
        CALL ALLOC(EL%vm,S_B_FROM_V%N_MONO)
    

    ! 2010 January 6
  END SUBROUTINE ALLOCTEAPOT

  SUBROUTINE KILLTEAPOT(EL)
    IMPLICIT NONE
    TYPE(TEAPOTP), INTENT(INOUT)::EL

   !  IF(EL%ELECTRIC) THEN
        call kill(EL%E_X,S_E%N_MONO)
        call kill(EL%E_Y,S_E%N_MONO)
        call kill(EL%PHI,S_E%N_MONO)
        call kill(EL%AE,SECTOR_NMUL_max);call alloc(EL%BE,SECTOR_NMUL_max);
   !  endif
        CALL kill(EL%bf_x,S_B_FROM_V%N_MONO)
        CALL kill(EL%bf_Y,S_B_FROM_V%N_MONO)
        CALL kill(EL%vm,S_B_FROM_V%N_MONO)

  END SUBROUTINE KILLTEAPOT

!!!!!!!!!!!!!! Pancake starts here !!!!!!!!!!!!!!!

  subroutine fxr(f,x,k,b,p)
    implicit none

    real(dp)  d(3),c(6),BETA0,GAMMA0I,hcurv
    real(dp) ,intent(in) :: b(3)
    type(MAGNET_CHART), pointer:: p
    real(dp) ,intent(inout) :: x(6)
    real(dp), intent(out):: f(6)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    if(k%time) then
       beta0=p%beta0;GAMMA0I=p%GAMMA0I;
    else
       beta0=1.0_dp;GAMMA0I=0.0_dp;
    endif

    hcurv=p%b0

    d(1)=root(x(2)**2+x(4)**2+(1.0_dp+hcurv*x(1))**2)
    d(2)=(d(1)**3)/root(1.0_dp+2*x(5)/beta0+x(5)**2)
    d(3)=1.0_dp+hcurv*x(1)

    c(1)=d(1)**2-x(2)**2
    c(2)=-x(2)*x(4)
    c(3)= x(2)*x(4)
    c(4)=-d(1)**2+x(4)**2
    c(5)=d(2)*(x(4)*b(3)-d(3)*b(2)) +hcurv*d(3)*(d(1)**2+x(2)**2)
    c(6)=d(2)*(x(2)*b(3)-d(3)*b(1)) -hcurv*d(3)*c(3)

    d(3)=c(1)*c(4)-c(2)*c(3)
    f(1)=x(2)
    f(2)=(c(4)*c(5)-c(2)*c(6))/d(3)
    f(3)=x(4)
    f(4)=(c(1)*c(6)-c(3)*c(5))/d(3)
    d(2)=1.0_dp+2.0_dp*x(5)/beta0+x(5)**2
    d(2)=gamma0I/beta0/d(2)
    f(6)=root((1+d(2)**2))*d(1)  ! (time)-prime = dt/dz

    !    if(p%radiation) then
    !       c(1)=x(2)/d(1)
    !       c(2)=x(4)/d(1)
    !       c(3)=one/d(1)
    !       B2=zero
    !       B2=(B(2)*c(3)-B(3)*c(2))**2+B2
    !       B2=(B(1)*c(2)-B(2)*c(1))**2+B2
    !       B2=(B(3)*c(1)-B(1)*c(3))**2+B2
    !       f(5)=-CRADF(P)*(one+X(5))**2*B2*f(6)
    !    else
    f(5)=0.0_dp
    !    endif


  end subroutine fxr

  subroutine fxp(f,x,k,b,p)
    implicit none

    type(real_8)  d(3),c(6)
    type(real_8) ,intent(inout) :: x(6)
    type(real_8) ,intent(in) :: b(3)
    real(dp)   BETA0,GAMMA0I,hcurv
    type(real_8), intent(out):: f(6)
    type(MAGNET_CHART), pointer:: p
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    call alloc(d,3)
    call alloc(c,6)
    hcurv=p%b0
    if(k%time) then
       beta0=p%beta0;GAMMA0I=p%GAMMA0I;
    else
       beta0=1.0_dp;GAMMA0I=0.0_dp;
    endif

    d(1)=SQRT(x(2)**2+x(4)**2+(1.0_dp+hcurv*x(1))**2)
    d(2)=(d(1)**3)/SQRT(1.0_dp+2*x(5)/beta0+x(5)**2)
    d(3)=1.0_dp+hcurv*x(1)

    c(1)=d(1)**2-x(2)**2
    c(2)=-x(2)*x(4)
    c(3)= x(2)*x(4)
    c(4)=-d(1)**2+x(4)**2
    c(5)=d(2)*(x(4)*b(3)-d(3)*b(2)) +hcurv*d(3)*(d(1)**2+x(2)**2)
    c(6)=d(2)*(x(2)*b(3)-d(3)*b(1)) -hcurv*d(3)*c(3)

    d(3)=c(1)*c(4)-c(2)*c(3)
    f(1)=x(2)
    f(2)=(c(4)*c(5)-c(2)*c(6))/d(3)
    f(3)=x(4)
    f(4)=(c(1)*c(6)-c(3)*c(5))/d(3)
    f(5)=0.0_dp
    d(2)=1.0_dp+2.0_dp*x(5)/beta0+x(5)**2
    !   d(2)=SQRT((one+d(2)*gambet)/d(2)/gambet)
    !   f(6)=d(2)*d(1)

    d(2)=gamma0I/beta0/d(2)
    f(6)=SQRT((1+d(2)**2))*d(1)  ! (time)-prime = dt/dz

    f(5)=0.0_dp

    call kill(d,3)
    call kill(c,6)
  end subroutine fxp

  ! TYPE PANCAKE


  SUBROUTINE ZEROr_PANCAKE(EL,I)
    IMPLICIT NONE
    TYPE(PANCAKE), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%B)) then
          CALL KILL(EL%B)    ! forgotten???
          deallocate(EL%B)
          !          deallocate(EL%Ax)
          !          deallocate(EL%Ay)

          deallocate(EL%SCALE)
          !          deallocate(EL%D_IN)
          !          deallocate(EL%D_OUT)
          !          deallocate(EL%ANG_IN)
          !          deallocate(EL%ANG_OUT)
       endif

    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%B)
       NULLIFY(EL%SCALE)
       !       NULLIFY(EL%Ax)
       !       NULLIFY(EL%Ay)
       !       NULLIFY(EL%D_IN)
       !       NULLIFY(EL%D_OUT)
       !       NULLIFY(EL%ANG_IN)
       !       NULLIFY(EL%ANG_OUT)
    endif

  END SUBROUTINE ZEROr_PANCAKE

  SUBROUTINE ZEROP_PANCAKE(EL,I)
    IMPLICIT NONE
    TYPE(PANCAKEP), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%B)) then
          CALL KILL(EL%SCALE)
          CALL KILL(EL%B)
          !          CALL KILL(EL%Ax)
          !          CALL KILL(EL%Ay)

          !          deallocate(EL%Ax)
          !          deallocate(EL%Ay)
          deallocate(EL%B)
          deallocate(EL%SCALE)
          !          deallocate(EL%D_IN)
          !          deallocate(EL%D_OUT)
          !          deallocate(EL%ANG_IN)
          !          deallocate(EL%ANG_OUT)
       endif

    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%B)
       !       NULLIFY(EL%Ax)
       !       NULLIFY(EL%Ay)
       NULLIFY(EL%SCALE)
       !       NULLIFY(EL%D_IN)
       !       NULLIFY(EL%D_OUT)
       !       NULLIFY(EL%ANG_IN)
       !       NULLIFY(EL%ANG_OUT)
    endif

  END SUBROUTINE ZEROP_PANCAKE

  SUBROUTINE POINTERS_PANCAKER(EL,T) !,t_ax,t_ay)
    IMPLICIT NONE
    TYPE(PANCAKE), INTENT(INOUT)::EL
    TYPE(TREE_ELEMENT), INTENT(IN)::T(:) !,T_ax(:) ,T_ay(:)  ! DATA PASSED HERE SPECIAL
    INTEGER I

    ALLOCATE(EL%B(2*el%p%NST+1))
    !    ALLOCATE(EL%Ax(el%p%NST))
    !    ALLOCATE(EL%Ay(el%p%NST))
    ALLOCATE(  EL%SCALE )
    !    ALLOCATE(  EL%D_IN(3) )
    !    ALLOCATE(  EL%D_OUT(3) )
    !    ALLOCATE(  EL%ANG_IN(3) )
    !    ALLOCATE(  EL%ANG_OUT(3) )

    DO I=1,2*el%p%NST+1
       CALL ALLOC_TREE(EL%B(I),T(I)%N,3)
       !       CALL ALLOC_TREE(EL%Ax(I),T_ax(I)%N,2)
       !       CALL ALLOC_TREE(EL%Ay(I),T_ay(I)%N,2)
       EL%B(I)%CC=T(I)%CC
       EL%B(I)%JL=T(I)%JL
       EL%B(I)%JV=T(I)%JV
       EL%B(I)%N=T(I)%N
       EL%B(I)%ND2=T(I)%ND2
       EL%B(I)%no=T(I)%no
       !       EL%ax(I)%CC=t_ax(I)%CC
       !       EL%ax(I)%JL=t_ax(I)%JL
       !       EL%ax(I)%JV=t_ax(I)%JV
       !       EL%ax(I)%N=t_ax(I)%N
       !       EL%ax(I)%ND2=t_ax(I)%ND2
       !
       !       EL%ay(I)%CC=t_ay(I)%CC
       !       EL%ay(I)%JL=t_ay(I)%JL
       !       EL%ay(I)%JV=t_ay(I)%JV
       !       EL%ay(I)%N=t_ay(I)%N
       !       EL%ay(I)%ND2=t_ay(I)%ND2
    ENDDO



    EL%SCALE=1.0_dp
    !    EL%D_IN=ZERO
    !    EL%D_OUT=ZERO
    !    EL%ANG_IN=ZERO
    !    EL%ANG_OUT=ZERO

  END SUBROUTINE POINTERS_PANCAKER

  SUBROUTINE POINTERS_PANCAKEP(EL,T) !,t_ax,t_ay)
    IMPLICIT NONE
    TYPE(PANCAKEP), INTENT(INOUT)::EL
    TYPE(TREE_ELEMENT), INTENT(IN)::T(:) !,t_ax(:),t_ay(:) ! DATA PASSED HERE SPECIAL
    INTEGER I



    ALLOCATE(EL%B(2*el%p%NST+1))
    !    ALLOCATE(EL%Ax(el%p%NST))
    !    ALLOCATE(EL%Ay(el%p%NST))
    ALLOCATE(  EL%SCALE )
    !    ALLOCATE(  EL%D_IN(3) )
    !    ALLOCATE(  EL%D_OUT(3) )
    !    ALLOCATE(  EL%ANG_IN(3) )
    !    ALLOCATE(  EL%ANG_OUT(3) )

    DO I=1,2*el%p%NST+1
       CALL ALLOC_TREE(EL%B(I),T(I)%N,3)
       !       CALL ALLOC_TREE(EL%Ax(I),T_ax(I)%N,2)
       !       CALL ALLOC_TREE(EL%Ay(I),T_ay(I)%N,2)
       EL%B(I)%CC=T(I)%CC
       EL%B(I)%JL=T(I)%JL
       EL%B(I)%JV=T(I)%JV
       EL%B(I)%N=T(I)%N
       EL%B(I)%ND2=T(I)%ND2
       EL%B(I)%no=T(I)%no
       !       EL%ax(I)%CC=t_ax(I)%CC
       !       EL%ax(I)%JL=t_ax(I)%JL
       !       EL%ax(I)%JV=t_ax(I)%JV
       !       EL%ax(I)%N=t_ax(I)%N
       !       EL%ax(I)%ND2=t_ax(I)%ND2
       !
       !       EL%ay(I)%CC=t_ay(I)%CC
       !       EL%ay(I)%JL=t_ay(I)%JL
       !       EL%ay(I)%JV=t_ay(I)%JV
       !       EL%ay(I)%N=t_ay(I)%N
       !       EL%ay(I)%ND2=t_ay(I)%ND2
    ENDDO



    !    EL%D_IN=ZERO
    !    EL%D_OUT=ZERO
    !    EL%ANG_IN=ZERO
    !    EL%ANG_OUT=ZERO
    ! EL%SCALE MUST BE CREATED IN SETFAMILYP
  END SUBROUTINE POINTERS_PANCAKEP

  SUBROUTINE copyPANCAKE_el_elp(EL,ELP)
    IMPLICIT NONE
    TYPE(PANCAKE), INTENT(in)::EL
    TYPE(PANCAKEP), INTENT(inout)::ELP

    CALL COPY_TREE_N(EL%B,ELP%B)
    !    CALL COPY_TREE_N(EL%ax,ELP%ax)
    !    CALL COPY_TREE_N(EL%ay,ELP%ay)
    !
    !!    ELP%D_IN    =  EL%D_IN
    !    ELP%D_OUT    =  EL%D_OUT
    !    ELP%ANG_IN    =  EL%ANG_IN
    !    ELP%ANG_OUT    =  EL%ANG_OUT
    ELP%SCALE  = EL%SCALE
  END SUBROUTINE copyPANCAKE_el_elp

  SUBROUTINE copyPANCAKE_el_el(EL,ELP)
    IMPLICIT NONE
    TYPE(PANCAKE), INTENT(in)::EL
    TYPE(PANCAKE), INTENT(inout)::ELP

    CALL COPY_TREE_N(EL%B,ELP%B)
    !    CALL COPY_TREE_N(EL%ax,ELP%ax)
    !    CALL COPY_TREE_N(EL%ay,ELP%ay)
    !
    !!    ELP%D_IN    =  EL%D_IN
    !    ELP%D_OUT    =  EL%D_OUT
    !    ELP%ANG_IN    =  EL%ANG_IN
    !    ELP%ANG_OUT    =  EL%ANG_OUT
    ELP%SCALE  = EL%SCALE
  END SUBROUTINE copyPANCAKE_el_el

  SUBROUTINE copyPANCAKE_elP_el(EL,ELP)
    IMPLICIT NONE
    TYPE(PANCAKEP), INTENT(in)::EL
    TYPE(PANCAKE), INTENT(inout)::ELP

    CALL COPY_TREE_N(EL%B,ELP%B)
    !    CALL COPY_TREE_N(EL%ax,ELP%ax)
    !    CALL COPY_TREE_N(EL%ay,ELP%ay)
    !
    !!    ELP%D_IN    =  EL%D_IN
    !    ELP%D_OUT    =  EL%D_OUT
    !    ELP%ANG_IN    =  EL%ANG_IN
    !    ELP%ANG_OUT    =  EL%ANG_OUT
    ELP%SCALE  = EL%SCALE
  END SUBROUTINE copyPANCAKE_elP_el

  SUBROUTINE reset_pa(EL)
    IMPLICIT NONE
    TYPE(PANCAKEP), INTENT(INOUT)::EL
    ! CALL resetpoly_R31 ON ALL THE INTERNAL POLYMORPHS

    call resetpoly_R31(EL%SCALE)

  END SUBROUTINE reset_pa

  subroutine feval_PANCAkEr(POS,X,k,f,EL)
    IMPLICIT NONE
    real(dp), INTENT(INout) :: X(6)
    INTEGER, INTENT(INOUT) :: POS
    real(dp), INTENT(OUT) :: F(6)
    TYPE(PANCAKE),  INTENT(INOUT) :: EL
    real(dp) B(3)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    B(1)=X(1);
    B(2)=X(3);
    B(3)=0.0_dp;

    !       CALL track3(EL%B(POS),B)
    CALL trackg(EL%B(POS),B)

    b(1)=EL%SCALE*el%p%charge*el%p%dir*b(1)
    b(2)=EL%SCALE*el%p%charge*el%p%dir*b(2)
    !    b(3)=EL%SCALE*el%p%charge*el%p%dir*b(3)
    b(3)=EL%SCALE*el%p%charge*b(3)

    CALL f_M(f,x,k,b,EL%p)

  END subroutine feval_PANCAkEr

  subroutine feval_PANCAkEP(POS,X,k,f,EL)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INout) :: X(6)
    INTEGER, INTENT(INOUT) :: POS
    TYPE(REAL_8), INTENT(OUT) :: F(6)
    TYPE(PANCAKEP),  INTENT(INOUT) :: EL
    TYPE(REAL_8) B(3)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    CALL ALLOC(B)
    B(1)=X(1);
    B(2)=X(3);
    B(3)=0.0_dp;

    !       CALL track3(EL%B(POS),B)
    CALL trackg(EL%B(POS),B)

    b(1)=EL%SCALE*el%p%charge*el%p%dir*b(1)
    b(2)=EL%SCALE*el%p%charge*el%p%dir*b(2)
    !    b(3)=EL%SCALE*el%p%charge*el%p%dir*b(3)
    b(3)=EL%SCALE*el%p%charge*b(3)

    CALL f_M(f,x,k,b,EL%p)

    CALL KILL(B)

  END subroutine feval_PANCAkEP

  ! 4 order Runge
  subroutine rk4_pancaker(ti,h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    real(dp), INTENT(INOUT)::  y(ne)
    real(dp)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne)
    type (pancake) ,INTENT(INOUT)::  GR
    integer j
    real(dp), intent(inout) :: h
    integer, intent(inout) :: ti
    INTEGER TT
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    call feval(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    tt=tI+GR%p%dir
    call feval(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + b(j)/2.0_dp
    enddo


    tt=tI+GR%p%dir
    call feval(tt,yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+c(j)
    enddo

    tt=tI+2*GR%p%dir
    call feval(tt,yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+(a(j)+2.0_dp*b(j)+2.0_dp*c(j)+d(j))/6.0_dp
    enddo
    tI=ti+2*GR%p%dir

    if(k%TIME) then
       Y(6)=Y(6)-(1-k%TOTALPATH)*GR%P%LD/GR%P%beta0/GR%P%nst
    else
       Y(6)=Y(6)-(1-k%TOTALPATH)*GR%P%LD/GR%P%nst
    endif

    return
  end  subroutine rk4_pancaker

  subroutine rk4_pancakeP(ti,h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    TYPE(REAL_8), INTENT(INOUT)::  y(ne)
    TYPE(REAL_8)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne)
    type (pancakeP) ,INTENT(INOUT)::  GR
    integer j
    TYPE(REAL_8), intent(inout) :: h
    integer, intent(inout) :: ti
    INTEGER TT
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    call alloc(yt,ne)
    call alloc(f,ne)
    call alloc(a,ne)
    call alloc(b,ne)
    call alloc(c,ne)
    call alloc(d,ne)


    call feval(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    tt=tI+GR%p%dir
    call feval(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + b(j)/2.0_dp
    enddo


    tt=tI+GR%p%dir
    call feval(tt,yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+c(j)
    enddo

    tt=tI+2*GR%p%dir
    call feval(tt,yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo


    do  j=1,ne
       y(j) = y(j)+(a(j)+2.0_dp*b(j)+2.0_dp*c(j)+d(j))/6.0_dp
    enddo
    tI=ti+2*GR%p%dir

    if(k%TIME) then
       Y(6)=Y(6)-(1-k%TOTALPATH)*GR%P%LD/GR%P%beta0/GR%P%nst
    else
       Y(6)=Y(6)-(1-k%TOTALPATH)*GR%P%LD/GR%P%nst
    endif

    call KILL(yt,ne)
    call KILL(f,ne)
    call KILL(a,ne)
    call KILL(b,ne)
    call KILL(c,ne)
    call KILL(d,ne)

    return
  end  subroutine rk4_pancakeP

  SUBROUTINE conv_to_xpr(EL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(PANCAKE),INTENT(INOUT):: EL
    real(dp) ti
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    if(k%TIME) then
       ti=ROOT(1.0_dp+2.0_dp*X(5)/el%p%beta0+x(5)**2-X(2)**2-X(4)**2)
       x(2)=(1.0_dp+el%p%B0*X(1))*x(2)/ti
       x(4)=(1.0_dp+el%p%B0*X(1))*x(4)/ti
    else
       ti=ROOT((1.0_dp+x(5))**2-X(2)**2-X(4)**2)
       x(2)=(1.0_dp+el%p%B0*X(1))*x(2)/ti
       x(4)=(1.0_dp+el%p%B0*X(1))*x(4)/ti
    endif

  end SUBROUTINE conv_to_xpr

  SUBROUTINE conv_to_xpp(EL,X,k)
    IMPLICIT NONE
    type(real_8),INTENT(INOUT):: X(6)
    TYPE(PANCAKEp),INTENT(INOUT):: EL
    type(real_8) ti
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    call alloc(ti)
    if(k%TIME) then
       ti=sqrt(1.0_dp+2.0_dp*X(5)/el%p%beta0+x(5)**2-X(2)**2-X(4)**2)
       x(2)=(1.0_dp+el%p%B0*X(1))*x(2)/ti
       x(4)=(1.0_dp+el%p%B0*X(1))*x(4)/ti
    else
       ti=sqrt((1.0_dp+x(5))**2-X(2)**2-X(4)**2)
       x(2)=(1.0_dp+el%p%B0*X(1))*x(2)/ti
       x(4)=(1.0_dp+el%p%B0*X(1))*x(4)/ti
    endif
    call kill(ti)

  end SUBROUTINE conv_to_xpp

  SUBROUTINE conv_to_pxr(EL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(PANCAKE),INTENT(INOUT):: EL
    real(dp) ti
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    ti=ROOT((1.0_dp+el%p%B0*X(1))**2+X(2)**2+X(4)**2)
    if(k%TIME) then
       x(2)=x(2)*ROOT(1.0_dp+2.0_dp*X(5)/el%p%beta0+x(5)**2)/ti
       x(4)=x(4)*ROOT(1.0_dp+2.0_dp*X(5)/el%p%beta0+x(5)**2)/ti
    else
       x(2)=x(2)*(1.0_dp+x(5))/ti
       x(4)=x(4)*(1.0_dp+x(5))/ti
    endif
  end SUBROUTINE conv_to_pxr

  SUBROUTINE conv_to_pxp(EL,X,k)
    IMPLICIT NONE
    type(real_8),INTENT(INOUT):: X(6)
    TYPE(PANCAKEp),INTENT(INOUT):: EL
    type(real_8) ti
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    call alloc(ti)
    ti=SQRT((1.0_dp+el%p%B0*X(1))**2+X(2)**2+X(4)**2)
    if(k%TIME) then
       x(2)=x(2)*sqrt(1.0_dp+2.0_dp*X(5)/el%p%beta0+x(5)**2)/ti
       x(4)=x(4)*sqrt(1.0_dp+2.0_dp*X(5)/el%p%beta0+x(5)**2)/ti
    else
       x(2)=x(2)*(1.0_dp+x(5))/ti
       x(4)=x(4)*(1.0_dp+x(5))/ti
    endif
    call kill(ti)

  end SUBROUTINE conv_to_pxp


  ! ETIENNE_PANCAKE

  SUBROUTINE ADJUSTR_PANCAKE(EL,X,k,J)
    IMPLICIT NONE
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(PANCAKE),INTENT(INOUT):: EL

    INTEGER, INTENT(IN) :: J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(J==1) then
       call conv_to_xp(el,x,k)
    else
       call conv_to_px(el,x,k)
    endif

  END SUBROUTINE ADJUSTR_PANCAKE

  SUBROUTINE ADJUSTP_PANCAKE(EL,X,k,J)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(PANCAKEP),INTENT(INOUT):: EL

    INTEGER, INTENT(IN) :: J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(J==1) then
       call conv_to_xp(el,x,k)
    else
       call conv_to_px(el,x,k)
    endif

  END SUBROUTINE ADJUSTP_PANCAKE

  SUBROUTINE INTER_PANCAKE(EL,X,k,POS)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(PANCAKE),INTENT(INOUT):: EL
    integer, intent(in) :: POS
    INTEGER IS
    real(dp) h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    H=el%L/el%p%NST

    SELECT CASE(EL%P%METHOD)
    CASE(4)
       IF(EL%P%DIR==1) THEN
          IS=-1+2*POS    ! POS=3 BEGINNING
          call rk4_m(IS,h,el,X,k)
       else
          IS=2*el%p%NST+3-2*pos
          call rk4_m(IS,h,el,X,k)
       ENDIF

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT


  END SUBROUTINE INTER_PANCAKE

  SUBROUTINE INTEP_PANCAKE(EL,X,k,POS)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(PANCAKEP),INTENT(INOUT):: EL
    integer, intent(in) :: POS
    INTEGER IS
    TYPE(REAL_8) ti,h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ALLOC(TI,H)

    H=el%L/el%p%NST

    SELECT CASE(EL%P%METHOD)
    CASE(4)
       IF(EL%P%DIR==1) THEN
          IS=-1+2*POS    ! POS=3 BEGINNING

          call rk4_m(IS,h,el,X,k)
       else
          IS=2*el%p%NST+3-2*pos
          call rk4_m(IS,h,el,X,k)
       ENDIF

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

    CALL KILL(TI,H)

  END SUBROUTINE INTEP_PANCAKE


  SUBROUTINE INTPANCAKER(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(PANCAKE),INTENT(INOUT):: EL
    INTEGER I,IS
    real(dp) h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    H=el%L/el%p%NST

    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    SELECT CASE(EL%P%METHOD)
    CASE(4)
       call conv_to_xp(EL,X,k)
       IF(EL%P%DIR==1) THEN
          IS=1
          DO I=1,el%p%NST
             IF(.NOT.PRESENT(MID)) call rk4_m(IS,h,el,X,k)
             IF(PRESENT(MID)) CALL XMID(MID,X,I)
          ENDDO
       else
          IS=2*el%p%NST+1
          DO I=1,el%p%NST
             IF(.NOT.PRESENT(MID)) call rk4_m(IS,h,el,X,k)
             IF(PRESENT(MID)) CALL XMID(MID,X,I)
          ENDDO

       ENDIF
       call conv_to_px(EL,X,k)

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT




  END SUBROUTINE INTPANCAKER

  SUBROUTINE INTPANCAKEP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    ! TYPE(WORM_8),OPTIONAL,INTENT(INOUT):: MID
    TYPE(PANCAKEP),INTENT(INOUT):: EL
    INTEGER I,IS
    TYPE(REAL_8) ti,h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ALLOC(TI,H)


    H=el%L/el%p%NST




    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    SELECT CASE(EL%P%METHOD)
    CASE(4)
       call conv_to_xp(EL,X,k)
       IF(EL%P%DIR==1) THEN
          IS=1
          DO I=1,el%p%NST
             call rk4_m(IS,h,el,X,k)
          ENDDO
       else
          IS=2*el%p%NST+1
          DO I=1,el%p%NST
             call rk4_m(IS,h,el,X,k)
          ENDDO

       ENDIF


       call conv_to_px(EL,X,k)
       !       CASE(2)
       !          IS=1
       !          call DRIFT_pancake(EL,hh,is,1,X,k)
       !          call DRIFT_pancake(EL,hh,is,2,X,k)
       !          call KICKPATH(EL,hf,X,k)
       !          DO I=1,el%p%NST-2
       !             IS=is+1
       !             call DRIFT_pancake(EL,hh,is,2,X,k)
       !             call DRIFT_pancake(EL,hf,is,1,X,k)
       !             call DRIFT_pancake(EL,hh,is,2,X,k)
       !             call KICKPATH(EL,hf,X,k)
       !          ENDDO
       !          IS=is+1
       !          call DRIFT_pancake(EL,hh,is,2,X,k)
       !          call DRIFT_pancake(EL,hf,is,1,X,k)
       !          a(1)=x(1)
       !          a(2)=x(3)
       !          CALL trackg(EL%ax(is),A)
       !          X(2)=X(2)-EL%SCALE*el%p%charge*A(1)
       !          a(1)=x(1)
       !          a(2)=x(3)
       !          CALL trackg(EL%ay(is),A)
       !          X(4)=X(4)-EL%SCALE*el%p%charge*A(1)
       !

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT




    CALL KILL(TI,H)

  END SUBROUTINE INTPANCAKEP

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! cav_trav

  subroutine feval_CAVR(Z0,X,k,f,D) 
    IMPLICIT NONE
    real(dp), INTENT(INout) :: X(6)
    real(dp),INTENT(INOUT):: Z0
    real(dp), INTENT(INOUT) :: F(6)
    REAL(DP) A(3),AD(2),PZ
    TYPE(CAV_TRAV),  INTENT(INOUT) :: D
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    A=0.0_dp;AD=0.0_dp;
    CALL A_TRANS(D,Z0,X,k,A,AD)

    X(2)=X(2)-A(1)
    X(4)=X(4)-A(2)

    IF(D%P%EXACT) THEN
       if(k%TIME) then
          PZ=ROOT(1.0_dp+2.0_dp*X(5)/D%P%BETA0+x(5)**2-X(2)**2-X(4)**2)
          F(1)=X(2)/PZ
          F(3)=X(4)/PZ
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=(1.0_dp/D%P%BETA0+X(5))/PZ-(1-k%TOTALPATH)/D%P%BETA0
       else
          PZ=ROOT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          F(1)=X(2)/PZ
          F(3)=X(4)/PZ
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=(1.0_dp+X(5))/PZ-(1-k%TOTALPATH)
       endif
    ELSE
       if(k%TIME) then
          PZ=ROOT(1.0_dp+2.0_dp*X(5)/D%P%BETA0+x(5)**2)
          F(1)=X(2)/PZ
          F(3)=X(4)/PZ
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=((X(2)*X(2)+X(4)*X(4))/2.0_dp/pz**2+1.0_dp)*(1.0_dp/D%P%BETA0+x(5))/pz
          F(6)=F(6)-(1-k%TOTALPATH)/D%P%BETA0
       else
          F(1)=X(2)/(1.0_dp+X(5))
          F(3)=X(4)/(1.0_dp+X(5))
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=(1.0_dp/(1.0_dp+X(5)))*(X(2)*X(2)+X(4)*X(4))/2.0_dp/(1.0_dp+X(5))+k%TOTALPATH
       endif
    ENDIF

    X(2)=X(2)+A(1)
    X(4)=X(4)+A(2)

  END subroutine feval_CAVR

  subroutine feval_CAVP(Z0,X,k,f,D)   ! MODELLED BASED ON DRIFT
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INout) :: X(6)
    TYPE(REAL_8), INTENT(INOUT):: Z0
    TYPE(REAL_8), INTENT(INOUT) :: F(6)
    TYPE(REAL_8)  A(3),AD(2),PZ
    TYPE(CAV_TRAVp),  INTENT(INOUT) :: D
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ALLOC(A)
    CALL ALLOC(AD)
    CALL ALLOC(PZ)


    CALL A_TRANS(D,Z0,X,k,A,AD)

    X(2)=X(2)-A(1)
    X(4)=X(4)-A(2)

    IF(D%P%EXACT) THEN
       if(k%TIME) then
          PZ=sqrt(1.0_dp+2.0_dp*X(5)/D%P%BETA0+x(5)**2-X(2)**2-X(4)**2)
          F(1)=X(2)/PZ
          F(3)=X(4)/PZ
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=(1.0_dp/D%P%BETA0+X(5))/PZ-(1-k%TOTALPATH)/D%P%BETA0
       else
          PZ=sqrt((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          F(1)=X(2)/PZ
          F(3)=X(4)/PZ
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=(1.0_dp+X(5))/PZ-(1-k%TOTALPATH)
       endif
    ELSE
       if(k%TIME) then
          PZ=sqrt(1.0_dp+2.0_dp*X(5)/D%P%BETA0+x(5)**2)
          F(1)=X(2)/PZ
          F(3)=X(4)/PZ
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=((X(2)*X(2)+X(4)*X(4))/2.0_dp/pz**2+1.0_dp)*(1.0_dp/D%P%BETA0+x(5))/pz
          F(6)=F(6)-(1-k%TOTALPATH)/D%P%BETA0
       else
          F(1)=X(2)/(1.0_dp+X(5))
          F(3)=X(4)/(1.0_dp+X(5))
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=(1.0_dp/(1.0_dp+X(5)))*(X(2)*X(2)+X(4)*X(4))/2.0_dp/(1.0_dp+X(5))+k%TOTALPATH
       endif
    ENDIF

    X(2)=X(2)+A(1)
    X(4)=X(4)+A(2)

    CALL KILL(A)
    CALL KILL(AD)
    CALL KILL(PZ)


  END subroutine feval_CAVP

  SUBROUTINE A_TRANSR(EL,Z0,X,k,A,AD)    ! EXP(-I:(X^2+Y^2)/2*A_TRANS:)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(INOUT):: Z0,A(3),ad(2)
    TYPE(CAV_TRAV),INTENT(INOUT):: EL
    real(dp) C1,S1,C2,S2,V,O
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    !    IF(k%NOCAVITY.OR.(.NOT.k%FRINGE)) RETURN
    IF(k%NOCAVITY.and.(.not.EL%always_on)) RETURN
!    IF(k%NOCAVITY) RETURN

    O=EL%freq*twopi/CLIGHT
    C1=COS(O*(x(6)-Z0)+EL%PHAS+EL%phase0)
    C2=COS(O*(x(6)+Z0)+EL%PHAS+EL%phase0+EL%DPHAS)
    S1=SIN(O*(x(6)-Z0)+EL%PHAS+EL%phase0)
    S2=SIN(O*(x(6)+Z0)+EL%PHAS+EL%phase0+EL%DPHAS)
    V=EL%P%CHARGE*(EL%volt-el%dvds*z0)*volt_c/EL%P%P0C

    AD(1)=0.5_dp*V*(COS(EL%PSI)*S1-SIN(EL%PSI)*S2)
    AD(2)=O*0.5_dp*V*(COS(EL%PSI)*C1-SIN(EL%PSI)*C2)
    A(1)=AD(1)*X(1)
    A(2)=AD(1)*X(3)
    A(3)=-EL%P%DIR*V*(COS(EL%PSI)*S1+SIN(EL%PSI)*S2)


  END SUBROUTINE A_TRANSR


  SUBROUTINE A_TRANSP(EL,Z0,X,k,A,AD)    ! EXP(-I:(X^2+Y^2)/2*A_TRANS:)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(INOUT):: Z0,A(3),ad(2)
    TYPE(CAV_TRAVP),INTENT(INOUT):: EL
    TYPE(REAL_8) C1,S1,C2,S2,V,O
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(k%NOCAVITY.OR.(.NOT.k%FRINGE)) RETURN
!    IF(k%NOCAVITY) RETURN

    CALL ALLOC(C1,S1,C2,S2,V,O)
    O=EL%freq*twopi/CLIGHT
    C1=COS(O*(x(6)-Z0)+EL%PHAS+EL%phase0)
    C2=COS(O*(x(6)+Z0)+EL%PHAS+EL%phase0+EL%DPHAS)
    S1=SIN(O*(x(6)-Z0)+EL%PHAS+EL%phase0)
    S2=SIN(O*(x(6)+Z0)+EL%PHAS+EL%phase0+EL%DPHAS)
    V=EL%P%CHARGE*(EL%volt-el%dvds*z0)*volt_c/EL%P%P0C

    AD(1)=0.5_dp*V*(COS(EL%PSI)*S1-SIN(EL%PSI)*S2)
    AD(2)=O*0.5_dp*V*(COS(EL%PSI)*C1-SIN(EL%PSI)*C2)
    A(1)=AD(1)*X(1)
    A(2)=AD(1)*X(3)
    A(3)=-EL%P%DIR*V*(COS(EL%PSI)*S1+SIN(EL%PSI)*S2)

    CALL KILL(C1,S1,C2,S2,V,O)

  END SUBROUTINE A_TRANSP

  subroutine rk2_cavr(ti,h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    real(dp), INTENT(INOUT)::  y(ne)
    real(dp)  yt(ne),f(ne),a(ne),b(ne)
    real(dp)  tt
    type (cav_trav) ,INTENT(INOUT)::  GR
    integer j
    real(dp), intent(inout) :: ti,h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    call feval_cav(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    tt=tI+h/2.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+b(j)
    enddo
    tI=ti+h

    return
  end  subroutine rk2_cavr

  ! 2 order Runge
  subroutine rk2_cavp(ti,h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    type (real_8), INTENT(INOUT)::  y(ne)
    type (real_8)  yt(ne),f(ne),a(ne),b(ne)
    type (real_8)  tt
    type (cav_travp) ,INTENT(INOUT)::  GR
    integer j
    type(real_8), intent(inout) :: ti,h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    call alloc(yt,ne)
    call alloc(f,ne)
    call alloc(a,ne)
    call alloc(b,ne)

    call alloc(tt)

    call feval_cav(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    tt=tI+h/2.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+b(j)
    enddo
    tI=ti+h

    call kill(tt)
    call kill(yt,ne)
    call kill(f,ne)
    call kill(a,ne)
    call kill(b,ne)

    return
  end  subroutine rk2_cavp

  subroutine rk4_cavr(ti,h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    real(dp), INTENT(INOUT)::  y(ne)
    real(dp)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne)
    type (CAV_TRAV) ,INTENT(INOUT)::  GR
    integer j
    real(dp), intent(inout) :: h
    real(dp), intent(inout) :: ti
    real(dp) TT
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    call feval_cav(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    tt=tI+h/2.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + b(j)/2.0_dp
    enddo


    !      tt=tI+1
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+c(j)
    enddo

    tt=tI+h
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo


    do  j=1,ne
       y(j) = y(j)+(a(j)+2.0_dp*b(j)+2.0_dp*c(j)+d(j))/6.0_dp
    enddo
    tI=tt

    return
  end  subroutine rk4_cavr

  subroutine rk4_cavp(ti,h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    type(real_8), INTENT(INOUT)::  y(ne)
    type (CAV_TRAVp) ,INTENT(INOUT)::  GR
    type(real_8), intent(inout) :: h
    type(real_8), intent(inout) :: ti
    type(real_8)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne)
    type(real_8) TT
    integer j
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    call alloc(tt)
    call alloc(yt)
    call alloc(f)
    call alloc(a)
    call alloc(b)
    call alloc(c)
    call alloc(d)

    call feval_cav(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    tt=tI+h/2.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + b(j)/2.0_dp
    enddo


    !      tt=tI+1
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+c(j)
    enddo

    tt=tI+h
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo


    do  j=1,ne
       y(j) = y(j)+(a(j)+2.0_dp*b(j)+2.0_dp*c(j)+d(j))/6.0_dp
    enddo
    tI=tt

    call kill(tt)
    call kill(yt)
    call kill(f)
    call kill(a)
    call kill(b)
    call kill(c)
    call kill(d)

    return
  end  subroutine rk4_cavp

  subroutine rk6_cavr(ti,h,GR,y,k)
    IMPLICIT none
    !  Written by Rob Ryne, Spring 1986, based on a routine of
    !c  J. Milutinovic.
    !c  For a reference, see page 76 of F. Ceschino and J Kuntzmann,
    !c  Numerical Solution of Initial Value Problems, Prentice Hall 1966.
    !c  This integration routine makes local truncation errors at each
    !c  step of order h**7.
    !c  That is, it is locally correct through terms of order h**6.
    !c  Each step requires 8 function evaluations.

    integer ne
    parameter (ne=6)
    real(dp), INTENT(INOUT)::  y(ne)
    real(dp)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne),e(ne),g(ne),o(ne),p(ne)
    real(dp)  tt
    type (CAV_TRAV) ,INTENT(INOUT)::  GR
    integer j
    real(dp), intent(inout) :: ti,h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    call feval_cav(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/9.0_dp
    enddo
    tt=tI+h/9.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + (a(j) + 3.0_dp*b(j))/24.0_dp
    enddo
    tt=tI+h/6.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j)+(a(j)-3.0_dp*b(j)+4.0_dp*c(j))/6.0_dp
    enddo

    tt=tI+h/3.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j) + (-5.0_dp*a(j) + 27.0_dp*b(j) - 24.0_dp*c(j) + 6.0_dp*d(j))/8.0_dp
    enddo
    tt=tI+0.5_dp*h
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       e(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j) + (221.0_dp*a(j) - 981.0_dp*b(j) + 867.0_dp*c(j)- 102.0_dp*d(j) + e(j))/9.0_dp
    enddo
    tt = tI+2.0_dp*h/3.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do   j=1,ne
       g(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j) = y(j)+(-183.0_dp*a(j)+678.0_dp*b(j)-472.0_dp*c(j)-66.0_dp*d(j)+80.0_dp*e(j) + 3.0_dp*g(j))/48.0_dp
    enddo
    tt = tI + 5.0_dp*h/6.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       o(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j) = y(j)+(716.0_dp*a(j)-2079.0_dp*b(j)+1002.0_dp*c(j)+834.0_dp*d(j)-454.0_dp*e(j)-9.0_dp*g(j)+72.0_dp*o(j))/82.0_dp
    enddo

    tt = tI + h
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       p(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+(41.0_dp*a(j)+216.0_dp*c(j)+27.0_dp*d(j)+272.0_dp*e(j)+27.0_dp*g(j)+216.0_dp*o(j)+41.0_dp*p(j))/840.0_dp
    enddo
    tI=ti+h

    return
  end  subroutine rk6_cavr



  ! sixth order Runge
  subroutine rk6_cavp(ti,h,GR,y,k)
    IMPLICIT none


    integer ne
    parameter (ne=6)
    type (real_8), INTENT(INOUT)::  y(ne)
    type (real_8)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne),e(ne),g(ne),o(ne),p(ne)
    type (real_8)  tt
    type (cav_travp) ,INTENT(INOUT)::  GR
    integer j
    type(real_8), intent(inout) :: ti,h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    call alloc(yt,ne)
    call alloc(f,ne)
    call alloc(a,ne)
    call alloc(b,ne)
    call alloc(c,ne)
    call alloc(d,ne)
    call alloc(e,ne)
    call alloc(g,ne)
    call alloc(o,ne)
    call alloc(p,ne)
    call alloc(tt)

    call feval_cav(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/9.0_dp
    enddo
    tt=tI+h/9.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + (a(j) + 3.0_dp*b(j))/24.0_dp
    enddo
    tt=tI+h/6.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j)+(a(j)-3.0_dp*b(j)+4.0_dp*c(j))/6.0_dp
    enddo

    tt=tI+h/3.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j) + (-5.0_dp*a(j) + 27.0_dp*b(j) - 24.0_dp*c(j) + 6.0_dp*d(j))/8.0_dp
    enddo
    tt=tI+0.5_dp*h
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       e(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j) + (221.0_dp*a(j) - 981.0_dp*b(j) + 867.0_dp*c(j)- 102.0_dp*d(j) + e(j))/9.0_dp
    enddo
    tt = tI+2.0_dp*h/3.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do   j=1,ne
       g(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j) = y(j)+(-183.0_dp*a(j)+678.0_dp*b(j)-472.0_dp*c(j)-66.0_dp*d(j)+80.0_dp*e(j) + 3.0_dp*g(j))/48.0_dp
    enddo
    tt = tI + 5.0_dp*h/6.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       o(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j) = y(j)+(716.0_dp*a(j)-2079.0_dp*b(j)+1002.0_dp*c(j)+834.0_dp*d(j)-454.0_dp*e(j)-9.0_dp*g(j)+72.0_dp*o(j))/82.0_dp
    enddo

    tt = tI + h
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       p(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+(41.0_dp*a(j)+216.0_dp*c(j)+27.0_dp*d(j)+272.0_dp*e(j)+27.0_dp*g(j)+216.0_dp*o(j)+41.0_dp*p(j))/840.0_dp
    enddo
    tI=ti+h
    call kill(tt)
    call kill(yt,ne)
    call kill(f,ne)
    call kill(a,ne)
    call kill(b,ne)
    call kill(c,ne)
    call kill(d,ne)
    call kill(e,ne)
    call kill(g,ne)
    call kill(o,ne)
    call kill(p,ne)

    return
  end  subroutine rk6_cavp

!!!!!!!!!!!!!!!!!  Helical dipole !!!!!!!!!!!!!!!!!!!!!!!!!!!!

  SUBROUTINE ZEROR_HE22(EL,I)
    IMPLICIT NONE
    TYPE(HELICAL_DIPOLE), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%N_BESSEL)) then
          deallocate(EL%N_BESSEL)
       endif
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%N_BESSEL)
    endif

  END SUBROUTINE ZEROR_HE22

  SUBROUTINE ZEROP_HE22(EL,I)
    IMPLICIT NONE
    TYPE(HELICAL_DIPOLEP), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%N_BESSEL)) then
          deallocate(EL%N_BESSEL)
       endif
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%N_BESSEL)
    endif

  END SUBROUTINE ZEROP_HE22

  SUBROUTINE computeR_f4(EL,X,Z,DA2,B,A,d,int_ax_dy,int_aY_dX)
    IMPLICIT NONE
    TYPE(HELICAL_DIPOLE), INTENT(INOUT)::EL
    real(dp),  INTENT(IN)::X(6),Z
    real(dp), OPTIONAL, INTENT(INOUT)::DA2(2),B(3),A(2),int_ax_dy,int_aY_dX
    real(dp), OPTIONAL, INTENT(INOUT)::d(3,3)
    REAL(DP) R2,DF,AR,PHIR,PHIZ,PHASE ,DFR,DFR2,co,si,F,DA(3,3)
    REAL(DP) x1,y1,k
    real(dp) int_x2_f_by_x_dy,int_y2_f_by_y_dx,int_f

    x1=x(1)
    y1=x(3)
    R2=x1**2+y1**2
    k=EL%FREQ
    DF=k**2/4.0_DP
    F=1.0_dp+DF*R2/2.0_DP+DF*DF*R2**2/12.0_DP
    DFR=DF+DF*DF*R2/3.0_DP
    DFR2=DF+DF*DF*R2


    PHASE=k*Z+EL%PHAS
    CO=COS(PHASE)
    SI=SIN(PHASE)
    PHIR=EL%BN(1)*X(1)*SI +EL%AN(1)*X(3)*CO
    AR=-k*F*PHIR
    IF(PRESENT(A)) THEN
       A(1)=X(1)*AR
       A(2)=X(3)*AR
    ENDIF

    IF(PRESENT(B).or.present(d)) THEN
       da=0.0_dp
       DA(1,1)=-k*F*(EL%BN(1)*X(1)*SI +PHIR) &
            -X(1)**2*k*PHIR*DFR
       DA(1,2)=-k*F*(EL%AN(1)*X(1)*CO ) &
            -X(1)*X(3)*k*PHIR*DFR        !!!
       DA(2,1)=-k*F*(EL%BN(1)*X(3)*SI ) &    !!!! x(3)
            -X(1)*X(3)*k*PHIR*DFR
       DA(2,2)=-k*F*(EL%AN(1)*X(3)*CO +PHIR) &
            -X(3)**2*k*PHIR*DFR
       PHIZ=-EL%BN(1)*X(1)*CO +EL%AN(1)*X(3)*SI

       DA(1,3)=k**2*PHIZ*F*X(1)
       DA(2,3)=k**2*PHIZ*F*X(3)

       DA(3,1)=(F+R2*DFR)*(-EL%BN(1)*CO)+PHIZ*(2.0_dp*DFR+DFR2)*X(1)
       DA(3,2)=(F+R2*DFR)*(EL%AN(1)*SI)+ PHIZ*(2.0_dp*DFR+DFR2)*X(3)
       if(present(d)) d=da
    ENDIF
    IF(PRESENT(DA2)) THEN  !!
       PHIZ=-EL%BN(1)*X(1)*CO +EL%AN(1)*X(3)*SI

       DA2(1)=(F+R2*DFR)*(-EL%BN(1)*CO)+PHIZ*(2.0_dp*DFR+DFR2)*X(1)
       DA2(2)=(F+R2*DFR)*(EL%AN(1)*SI)+ PHIZ*(2.0_dp*DFR+DFR2)*X(3)
    ENDIF

    IF(PRESENT(B)) THEN
       B(1)=DA(3,2)-DA(2,3)
       B(2)=DA(1,3)-DA(3,1)
       B(3)=DA(2,1)-DA(1,2)
    ENDIF
    !int_x2_f_by_x= (x1**3*(35*k**4*Y1**4+840*k**2*Y1**2+6720)+x1**5*(42*k**4*Y1**2+504 &
    !            *k**2)+15*k**4*x1**7)/20160.0_dp

    !int_y2_f_by_y= (15*k**4*Y1**7+(42*k**4*x1**2+504*k**2)*Y1**5+(35*k**4*x1**4+840*k &
    !       **2*x1**2+6720)*Y1**3)/20160.0_dp


    if(present(int_ax_dy)) then
       int_f=r2/2.0_dp+k**2*r2**2/32.0_dp+k**4*r2**3/24.0_dp/48.0_dp
       int_x2_f_by_x_dy=(x1**3*(140*k**4*Y1**3+1680*k**2*Y1)+84*k**4*x1**5*Y1)/20160.0_dp
       int_ax_dy=k*EL%BN(1)*SI*int_x2_f_by_x_dy+ k*EL%AN(1)*CO*(int_f+Y1**2*F)
       int_ax_dy=-int_ax_dy
    endif
    if(present(int_aY_dX)) then
       int_f=r2/2.0_dp+k**2*r2**2/32.0_dp+k**4*r2**3/24.0_dp/48.0_dp
       int_y2_f_by_y_dx=(84*k**4*x1*Y1**5+(140*k**4*x1**3+1680*k**2*x1)*Y1**3)/20160.0_dp
       int_aY_dX=k*EL%BN(1)*SI*(int_f+x1**2*F) + k*EL%AN(1)*CO*int_y2_f_by_y_dx
       int_aY_dX=-int_aY_dX
    endif
  END SUBROUTINE computeR_f4

  SUBROUTINE computeP_f4(EL,X,Z,DA2,B,A,d,int_ax_dy,int_aY_dX)
    IMPLICIT NONE
    TYPE(HELICAL_DIPOLEP), INTENT(INOUT)::EL
    type(real_8),  INTENT(IN)::X(6),Z
    type(real_8), OPTIONAL, INTENT(INOUT):: DA2(2),B(3),A(2),int_ax_dy,int_aY_dX
    type(real_8)  R2,DF,AR,PHIR,PHIZ,PHASE ,DFR,DFR2,co,si
    type(real_8), OPTIONAL, INTENT(INOUT):: d(3,3)
    type(real_8) x1,y1,k,F,FR,DA(3,3)
    type(real_8) int_x2_f_by_x_dy,int_y2_f_by_y_dx,int_f
    INTEGER j,kk

    call alloc(R2,DF,AR,PHIR,PHIZ,PHASE ,DFR,DFR2,co,si)
    call alloc(x1,y1,k,F,FR )
    call alloc(int_x2_f_by_x_dy,int_y2_f_by_y_dx,int_f)
    x1=x(1)
    y1=x(3)
    R2=x1**2+y1**2
    k=EL%FREQ
    DF=k**2/4.0_DP
    F=1.0_dp  +DF*R2/2.0_DP +DF*DF*R2**2/12.0_DP
    DFR=0.0_dp+DF  +DF*DF*R2/3.0_DP
    DFR2=0.0_dp+DF +DF*DF*R2



    PHASE=k*Z+EL%PHAS
    CO=COS(PHASE)
    SI=SIN(PHASE)
    PHIR=EL%BN(1)*X(1)*SI +EL%AN(1)*X(3)*CO
    AR=-k*F*PHIR
    IF(PRESENT(A)) THEN
       A(1)=X(1)*AR
       A(2)=X(3)*AR
    ENDIF

    IF(PRESENT(B).or.present(d)) THEN
       do j=1,3
          do kk=1,3
             call alloc(da(j,kk))
          enddo
       enddo
       DA(1,1)=-k*F*(EL%BN(1)*X(1)*SI +PHIR) &
            -X(1)**2*k*PHIR*DFR
       DA(1,2)=-k*F*(EL%AN(1)*X(1)*CO ) &
            -X(1)*X(3)*k*PHIR*DFR        !!!
       DA(2,1)=-k*F*(EL%BN(1)*X(3)*SI ) &    !!!! x(3)
            -X(1)*X(3)*k*PHIR*DFR
       DA(2,2)=-k*F*(EL%AN(1)*X(3)*CO +PHIR) &
            -X(3)**2*k*PHIR*DFR
       PHIZ=-EL%BN(1)*X(1)*CO +EL%AN(1)*X(3)*SI

       DA(1,3)=k**2*PHIZ*F*X(1)
       DA(2,3)=k**2*PHIZ*F*X(3)

       DA(3,1)=(F+R2*DFR)*(-EL%BN(1)*CO)+PHIZ*(2.0_dp*DFR+DFR2)*X(1)
       DA(3,2)=(F+R2*DFR)*(EL%AN(1)*SI)+ PHIZ*(2.0_dp*DFR+DFR2)*X(3)

       do j=1,3
          do kk=1,3
             if(present(d)) d(j,kk)=da(j,kk)
             !SRM DEBUG ... mmy
             !             call kill(da(j,kk))
          enddo
       enddo

    ENDIF
    IF(PRESENT(DA2)) THEN  !!
       PHIZ=-EL%BN(1)*X(1)*CO +EL%AN(1)*X(3)*SI

       DA2(1)=(F+R2*DFR)*(-EL%BN(1)*CO)+PHIZ*(2.0_dp*DFR+DFR2)*X(1)
       DA2(2)=(F+R2*DFR)*(EL%AN(1)*SI)+ PHIZ*(2.0_dp*DFR+DFR2)*X(3)
    ENDIF

    IF(PRESENT(B)) THEN
       B(1)=DA(3,2)-DA(2,3)
       B(2)=DA(1,3)-DA(3,1)
       B(3)=DA(2,1)-DA(1,2)
    ENDIF

    !SRM DEBUG ... alloc/kill mmy
    IF(PRESENT(B).or.present(d)) THEN
       do j=1,3
          do kk=1,3
             call kill(da(j,kk))
          enddo
       enddo
    ENDIF


    !int_x2_f_by_x= (x1**3*(35*k**4*Y1**4+840*k**2*Y1**2+6720)+x1**5*(42*k**4*Y1**2+504 &
    !            *k**2)+15*k**4*x1**7)/20160.0_dp

    !int_y2_f_by_y= (15*k**4*Y1**7+(42*k**4*x1**2+504*k**2)*Y1**5+(35*k**4*x1**4+840*k &
    !       **2*x1**2+6720)*Y1**3)/20160.0_dp


    if(present(int_ax_dy)) then
       int_f=r2/2.0_dp+k**2*r2**2/32.0_dp+k**4*r2**3/24.0_dp/48.0_dp
       int_x2_f_by_x_dy=(x1**3*(140*k**4*Y1**3+1680*k**2*Y1)+84*k**4*x1**5*Y1)/20160.0_dp
       int_ax_dy=k*EL%BN(1)*SI*int_x2_f_by_x_dy+ k*EL%AN(1)*CO*(int_f+Y1**2*F)
       int_ax_dy=-int_ax_dy
    endif
    if(present(int_aY_dX)) then
       int_f=r2/2.0_dp+k**2*r2**2/32.0_dp+k**4*r2**3/24.0_dp/48.0_dp
       int_y2_f_by_y_dx=(84*k**4*x1*Y1**5+(140*k**4*x1**3+1680*k**2*x1)*Y1**3)/20160.0_dp
       int_aY_dX=k*EL%BN(1)*SI*(int_f+x1**2*F) + k*EL%AN(1)*CO*int_y2_f_by_y_dx
       int_aY_dX=-int_aY_dX
    endif


    call kill(R2,DF,AR,PHIR,PHIZ,PHASE ,DFR,DFR2,co,si)
    call kill(x1,y1,k,F,FR )
    call kill(int_x2_f_by_x_dy,int_y2_f_by_y_dx,int_f)

  END SUBROUTINE computeP_f4


  SUBROUTINE KICKR_HE(EL,L,Z,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(HELICAL_DIPOLE),INTENT(INOUT):: EL
    real(dp),INTENT(IN):: L,Z
    real(dp) DA2(2)
    TYPE(INTERNAL_STATE) K

    CALL compute_f4(EL,X,Z,DA2=DA2)
    X(2)=X(2)+EL%p%charge*el%p%dir*L*DA2(1)
    X(4)=X(4)+EL%p%charge*el%p%dir*L*DA2(2)

  END SUBROUTINE KICKR_HE

  SUBROUTINE KICKP_HE(EL,L,Z,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(HELICAL_DIPOLEP),INTENT(INOUT):: EL
    TYPE(REAL_8),INTENT(IN):: L,Z
    TYPE(REAL_8) DA2(2)
    TYPE(INTERNAL_STATE) K

    CALL ALLOC(DA2,2)
    CALL compute_f4(EL,X,Z,DA2=DA2)
    X(2)=X(2)+EL%p%charge*el%p%dir*L*DA2(1)
    X(4)=X(4)+EL%p%charge*el%p%dir*L*DA2(2)
    CALL KILL(DA2,2)

  END SUBROUTINE KICKP_HE


  SUBROUTINE INTR_HE(EL,X,k,i)
    IMPLICIT NONE
    integer ipause, mypause
    real(dp),INTENT(INOUT):: X(6)
    TYPE(HELICAL_DIPOLE),INTENT(INOUT):: EL
    integer,INTENT(IN):: I
    real(dp) Z
    real(dp) D,DH
    real(dp) D1,D2,DK1,DK2
    real(dp) DF(4),DK(4)
    INTEGER J
    TYPE(INTERNAL_STATE)  K

    !    CALL SET_W(EL%W)

    SELECT CASE(EL%P%METHOD)
    CASE(2)
       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       IF(EL%P%DIR==1) THEN
          Z=(i-1)*d
       ELSE
          Z=EL%L-(i-1)*d
       ENDIF

       Z=Z+EL%P%DIR*DH
       CALL DRIFT(EL,DH,Z,1,X,K)
       CALL DRIFT(EL,DH,Z,2,X,K)
       CALL KICKPATH(EL,DH,Z,X,K)
       CALL KICK_HE(EL,D,Z,X,K)
       CALL KICKPATH(EL,DH,Z,X,K)
       CALL DRIFT(EL,DH,Z,2,X,K)
       CALL DRIFT(EL,DH,Z,1,X,K)
       !       Z=Z+EL%P%DIR*DH

    CASE(4)
       D=EL%L/EL%P%NST

       DK1=D*FK1
       D1=DK1/2.0_dp
       DK2=D*FK2
       D2=DK2/2.0_dp
       IF(EL%P%DIR==1) THEN
          Z=(i-1)*d
       ELSE
          Z=EL%L-(i-1)*d
       ENDIF

       Z=Z+EL%P%DIR*D1
       CALL DRIFT(EL,D1,Z,1,X,K)
       CALL DRIFT(EL,D1,Z,2,X,K)
       CALL KICKPATH(EL,D1,Z,X,K)
       CALL KICK_HE(EL,DK1,Z,X,K)
       CALL KICKPATH(EL,D1,Z,X,K)
       CALL DRIFT(EL,D1,Z,2,X,K)
       CALL DRIFT(EL,D1,Z,1,X,K)
       Z=Z+EL%P%DIR*(D1+D2)
       CALL DRIFT(EL,D2,Z,1,X,K)
       CALL DRIFT(EL,D2,Z,2,X,K)
       CALL KICKPATH(EL,D2,Z,X,K)
       CALL KICK_HE(EL,DK2,Z,X,K)
       CALL KICKPATH(EL,D2,Z,X,K)
       CALL DRIFT(EL,D2,Z,2,X,K)
       CALL DRIFT(EL,D2,Z,1,X,K)
       Z=Z+EL%P%DIR*(D1+D2)
       CALL DRIFT(EL,D1,Z,1,X,K)
       CALL DRIFT(EL,D1,Z,2,X,K)
       CALL KICKPATH(EL,D1,Z,X,K)
       CALL KICK_HE(EL,DK1,Z,X,K)
       CALL KICKPATH(EL,D1,Z,X,K)
       CALL DRIFT(EL,D1,Z,2,X,K)
       CALL DRIFT(EL,D1,Z,1,X,K)

    CASE(6)
       DO j =1,4
          DK(j)=EL%L*YOSK(J)/EL%P%NST
          DF(j)=DK(j)/2.0_dp
       ENDDO
       D=EL%L/EL%P%NST
       IF(EL%P%DIR==1) THEN
          Z=(i-1)*d
       ELSE
          Z=EL%L-(i-1)*d
       ENDIF
       DO J=4,1,-1
          Z=Z+EL%P%DIR*DF(J)
          CALL DRIFT(EL,DF(J),Z,1,X,K)
          CALL DRIFT(EL,DF(J),Z,2,X,K)
          CALL KICKPATH(EL,DF(J),Z,X,K)
          CALL KICK_HE(EL,DK(J),Z,X,K)
          CALL KICKPATH(EL,DF(J),Z,X,K)
          CALL DRIFT(EL,DF(J),Z,2,X,K)
          CALL DRIFT(EL,DF(J),Z,1,X,K)
          Z=Z+EL%P%DIR*DF(J)
       ENDDO
       DO J=2,4
          Z=Z+EL%P%DIR*DF(J)
          CALL DRIFT(EL,DF(J),Z,1,X,K)
          CALL DRIFT(EL,DF(J),Z,2,X,K)
          CALL KICKPATH(EL,DF(J),Z,X,K)
          CALL KICK_HE(EL,DK(J),Z,X,K)
          CALL KICKPATH(EL,DF(J),Z,X,K)
          CALL DRIFT(EL,DF(J),Z,2,X,K)
          CALL DRIFT(EL,DF(J),Z,1,X,K)
          Z=Z+EL%P%DIR*DF(J)
       ENDDO

    CASE DEFAULT
       WRITE(6,*) " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ipause=mypause(357)
    END SELECT

  END SUBROUTINE INTR_HE

  SUBROUTINE INTP_HE(EL,X,k,i)
    IMPLICIT NONE
    integer ipause, mypause
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(HELICAL_DIPOLEP),INTENT(INOUT):: EL
    integer,INTENT(IN):: I
    TYPE(REAL_8) Z
    TYPE(REAL_8) D,DH
    TYPE(REAL_8) D1,D2,DK1,DK2
    TYPE(REAL_8) DF(4),DK(4)
    INTEGER J
    TYPE(INTERNAL_STATE),OPTIONAL :: K

    CALL ALLOC(Z,D,DH,D1,D2,DK1,DK2)
    CALL ALLOC(DF,4)
    CALL ALLOC(DK,4)

    !    CALL SET_W(EL%W)
    SELECT CASE(EL%P%METHOD)
    CASE(2)
       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       IF(EL%P%DIR==1) THEN
          Z=(i-1)*d
       ELSE
          Z=EL%L-(i-1)*d
       ENDIF

       Z=Z+EL%P%DIR*DH
       CALL DRIFT(EL,DH,Z,1,X,K)
       CALL DRIFT(EL,DH,Z,2,X,K)
       CALL KICKPATH(EL,DH,Z,X,K)
       CALL KICK_HE(EL,D,Z,X,K)
       CALL KICKPATH(EL,DH,Z,X,K)
       CALL DRIFT(EL,DH,Z,2,X,K)
       CALL DRIFT(EL,DH,Z,1,X,K)
       !       Z=Z+EL%P%DIR*DH

    CASE(4)
       D=EL%L/EL%P%NST

       DK1=D*FK1
       D1=DK1/2.0_dp
       DK2=D*FK2
       D2=DK2/2.0_dp
       IF(EL%P%DIR==1) THEN
          Z=(i-1)*d
       ELSE
          Z=EL%L-(i-1)*d
       ENDIF

       Z=Z+EL%P%DIR*D1
       CALL DRIFT(EL,D1,Z,1,X,K)
       CALL DRIFT(EL,D1,Z,2,X,K)
       CALL KICKPATH(EL,D1,Z,X,K)
       CALL KICK_HE(EL,DK1,Z,X,K)
       CALL KICKPATH(EL,D1,Z,X,K)
       CALL DRIFT(EL,D1,Z,2,X,K)
       CALL DRIFT(EL,D1,Z,1,X,K)
       Z=Z+EL%P%DIR*(D1+D2)
       CALL DRIFT(EL,D2,Z,1,X,K)
       CALL DRIFT(EL,D2,Z,2,X,K)
       CALL KICKPATH(EL,D2,Z,X,K)
       CALL KICK_HE(EL,DK2,Z,X,K)
       CALL KICKPATH(EL,D2,Z,X,K)
       CALL DRIFT(EL,D2,Z,2,X,K)
       CALL DRIFT(EL,D2,Z,1,X,K)
       Z=Z+EL%P%DIR*(D1+D2)
       CALL DRIFT(EL,D1,Z,1,X,K)
       CALL DRIFT(EL,D1,Z,2,X,K)
       CALL KICKPATH(EL,D1,Z,X,K)
       CALL KICK_HE(EL,DK1,Z,X,K)
       CALL KICKPATH(EL,D1,Z,X,K)
       CALL DRIFT(EL,D1,Z,2,X,K)
       CALL DRIFT(EL,D1,Z,1,X,K)

    CASE(6)
       DO j =1,4
          DK(j)=EL%L*YOSK(j)/EL%P%NST
          DF(j)=DK(j)/2.0_dp
       ENDDO
       D=EL%L/EL%P%NST
       IF(EL%P%DIR==1) THEN
          Z=(i-1)*d
       ELSE
          Z=EL%L-(i-1)*d
       ENDIF
       DO J=4,1,-1
          Z=Z+EL%P%DIR*DF(J)
          CALL DRIFT(EL,DF(J),Z,1,X,K)
          CALL DRIFT(EL,DF(J),Z,2,X,K)
          CALL KICKPATH(EL,DF(J),Z,X,K)
          CALL KICK_HE(EL,DK(J),Z,X,K)
          CALL KICKPATH(EL,DF(J),Z,X,K)
          CALL DRIFT(EL,DF(J),Z,2,X,K)
          CALL DRIFT(EL,DF(J),Z,1,X,K)
          Z=Z+EL%P%DIR*DF(J)
       ENDDO
       DO J=2,4
          Z=Z+EL%P%DIR*DF(J)
          CALL DRIFT(EL,DF(J),Z,1,X,K)
          CALL DRIFT(EL,DF(J),Z,2,X,K)
          CALL KICKPATH(EL,DF(J),Z,X,K)
          CALL KICK_HE(EL,DK(J),Z,X,K)
          CALL KICKPATH(EL,DF(J),Z,X,K)
          CALL DRIFT(EL,DF(J),Z,2,X,K)
          CALL DRIFT(EL,DF(J),Z,1,X,K)
          Z=Z+EL%P%DIR*DF(J)
       ENDDO

    CASE DEFAULT
       WRITE(6,*) " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ipause=mypause(357)
    END SELECT

    CALL KILL(Z,D,DH,D1,D2,DK1,DK2)
    CALL KILL(DF,4)
    CALL KILL(DK,4)

  END SUBROUTINE INTP_HE

  SUBROUTINE INTR_HE_TOT(EL,X,k,mid)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(HELICAL_DIPOLE),INTENT(INOUT):: EL
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: mid
    INTEGER I
    TYPE(INTERNAL_STATE)  K

    !    CALL SET_W(EL%W)
    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    DO I=1,EL%P%NST
       call track_slice(el,x,k,i)
       IF(PRESENT(MID)) CALL XMID(MID,X,i)
    ENDDO


  END SUBROUTINE INTR_HE_TOT

  SUBROUTINE INTP_HE_TOT(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(HELICAL_DIPOLEP),INTENT(INOUT):: EL
    TYPE(INTERNAL_STATE)  K

    INTEGER I

    !    CALL SET_W(EL%W)


    DO I=1,EL%P%NST
       call track_slice(el,x,k,i)
    ENDDO


  END SUBROUTINE INTP_HE_TOT
  ! ETIENNE
  SUBROUTINE KICKPATHR_HE(EL,L,Z,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(HELICAL_DIPOLE),INTENT(INOUT):: EL
    real(dp),INTENT(IN):: L,Z
    real(dp) PZ,PZ0,DPZ
    TYPE(INTERNAL_STATE),OPTIONAL :: K
    ! ETIENNE
    !     CALL compute_f4(EL,X,Z,A=A,int_ax_dy=int_ax_dy)
    !      X(2)=X(2)-el%p%charge*A(1)
    !      X(4)=X(4)-el%p%charge*int_ax_dy
    !      CALL compute_f4(EL,X,Z,A=A,int_ax_dy=int_ax_dy)
    !       X(2)=X(2)+el%p%charge*A(1)
    !       X(4)=X(4)+el%p%charge*int_ax_dy

    IF(EL%P%EXACT) THEN
       ! CALL compute_f4(EL,X,Z,A=A)    !,int_ax_dy=int_ax_dy)
       !  X(2)=X(2)-el%p%charge*A(1)
       !  X(4)=X(4)-el%p%charge*A(2)

       if(k%TIME) then
          PZ=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2-X(2)**2-X(4)**2)
          PZ0=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
          DPZ=(X(2)**2+X(4)**2)/PZ/PZ0/(PZ+PZ0)   ! = (one/PZ-one/PZ0)
          X(1)=X(1)+L*X(2)*DPZ
          X(3)=X(3)+L*X(4)*DPZ

          X(6)=X(6)+L*(PZ0/PZ-(X(2)**2+X(4)**2)/PZ0**2/2.0_dp)*   &
               (1.0_dp/EL%P%BETA0+X(5))/PZ0 +(k%TOTALPATH-1)*L/EL%P%BETA0
       else
          PZ=ROOT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          PZ0=1.0_dp+X(5)
          DPZ=(X(2)**2+X(4)**2)/PZ/PZ0/(PZ+PZ0)   ! = (one/PZ-one/PZ0)
          X(1)=X(1)+L*X(2)*DPZ
          X(3)=X(3)+L*X(4)*DPZ
          X(6)=X(6)+L*(PZ0/PZ-(X(2)**2+X(4)**2)/PZ0**2/2.0_dp)+(k%TOTALPATH-1)*L
       endif
       !      CALL compute_f4(EL,X,Z,A=A) !,int_ax_dy=int_ax_dy)
       !       X(2)=X(2)+el%p%charge*A(1)
       !       X(4)=X(4)+el%p%charge*A(2)
    ELSE
       if(k%TIME) then
          PZ0=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
          X(6)=X(6)+L*(1.0_dp/EL%P%BETA0+x(5))/PZ0+(k%TOTALPATH-1)*L/EL%P%BETA0
       else
          X(6)=X(6)+k%TOTALPATH*L
       endif
    ENDIF

  END SUBROUTINE KICKPATHR_HE

  SUBROUTINE KICKPATHR_HE_exact_nonsymp(EL,L,Z,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(HELICAL_DIPOLE),INTENT(INOUT):: EL
    real(dp),INTENT(IN):: L,Z
    real(dp) PZ
    real(dp) A(3),da(3,3) !,int_ax_dy !,int_aY_dX
    TYPE(INTERNAL_STATE),OPTIONAL :: K
    ! ETIENNE

    IF(EL%P%EXACT) THEN
       CALL compute_f4(EL,X,Z,A=A,d=da)    !,int_ax_dy=int_ax_dy)
       X(2)=X(2) -el%p%charge*A(1)
       X(4)=X(4) -el%p%charge*A(2)
       if(k%TIME) then
          PZ=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2-X(2)**2-X(4)**2)
          X(1)=X(1)+L*X(2)/PZ
          X(3)=X(3)+L*X(4)/PZ
          ! multiply by el%p%charge forgotten
          X(2)=X(2)+el%p%charge*(L*X(4)/PZ*da(2,1)+L*X(2)/PZ*da(1,1))
          X(4)=X(4)+el%p%charge*(L*X(4)/PZ*da(2,2)+L*X(2)/PZ*da(1,2))
          X(6)=X(6)+L*(1.0_dp/EL%P%BETA0+X(5))/PZ+(k%TOTALPATH-1)*L/EL%P%BETA0
       else
          PZ=SQRT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          X(1)=X(1)+L*X(2)/PZ
          X(3)=X(3)+L*X(4)/PZ
          X(2)=X(2)+el%p%charge*(L*X(4)/PZ*da(2,1)+L*X(2)/PZ*da(1,1))
          X(4)=X(4)+el%p%charge*(L*X(4)/PZ*da(2,2)+L*X(2)/PZ*da(1,2))
          X(6)=X(6)+L*(1.0_dp+X(5))/PZ+(k%TOTALPATH-1)*L
       endif
       !      CALL compute_f4(EL,X,Z,A=A) !,int_ax_dy=int_ax_dy)
       X(2)=X(2) +el%p%charge*A(1)
       X(4)=X(4) +el%p%charge*A(2)
    ELSE
       if(k%TIME) then
          PZ=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
          X(6)=X(6)+L*(1.0_dp/EL%P%BETA0+x(5))/PZ+(k%TOTALPATH-1)*L/EL%P%BETA0
       else
          X(6)=X(6)+k%TOTALPATH*L
       endif
    ENDIF


  END SUBROUTINE KICKPATHR_HE_exact_nonsymp

  SUBROUTINE KICKPATHP_HE_exact_nonsymp(EL,L,Z,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(HELICAL_DIPOLEP),INTENT(INOUT):: EL
    TYPE(REAL_8),INTENT(IN):: L,Z
    TYPE(REAL_8) PZ,da(3,3),a(3)
    TYPE(INTERNAL_STATE),OPTIONAL :: K
    integer j,kk
    ! ETIENNE
    CALL ALLOC(PZ)
    IF(EL%P%EXACT) THEN
       CALL ALLOC(PZ)
       do j=1,3
          do kk=1,3
             call alloc(da(j,kk))
          enddo
       enddo
       call alloc(a)
       CALL compute_f4(EL,X,Z,A=A,d=da)    !,int_ax_dy=int_ax_dy)
       X(2)=X(2) -el%p%charge*A(1)
       X(4)=X(4) -el%p%charge*A(2)
       if(k%TIME) then
          PZ=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2-X(2)**2-X(4)**2)
          X(1)=X(1)+L*X(2)/PZ
          X(3)=X(3)+L*X(4)/PZ
          ! multiply by el%p%charge forgotten
          X(2)=X(2)+el%p%charge*(L*X(4)/PZ*da(2,1)+L*X(2)/PZ*da(1,1))
          X(4)=X(4)+el%p%charge*(L*X(4)/PZ*da(2,2)+L*X(2)/PZ*da(1,2))
          X(6)=X(6)+L*(1.0_dp/EL%P%BETA0+X(5))/PZ+(k%TOTALPATH-1)*L/EL%P%BETA0
       else
          PZ=SQRT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          X(1)=X(1)+L*X(2)/PZ
          X(3)=X(3)+L*X(4)/PZ
          X(2)=X(2)+el%p%charge*(L*X(4)/PZ*da(2,1)+L*X(2)/PZ*da(1,1))
          X(4)=X(4)+el%p%charge*(L*X(4)/PZ*da(2,2)+L*X(2)/PZ*da(1,2))
          X(6)=X(6)+L*(1.0_dp+X(5))/PZ+(k%TOTALPATH-1)*L
       endif
       do j=1,3
          do kk=1,3
             call kill(da(j,kk))
          enddo
       enddo
       !      CALL compute_f4(EL,X,Z,A=A) !,int_ax_dy=int_ax_dy)
       X(2)=X(2) +el%p%charge*A(1)
       X(4)=X(4) +el%p%charge*A(2)
       call kill(a)
    ELSE
       if(k%TIME) then
          PZ=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
          X(6)=X(6)+L*(1.0_dp/EL%P%BETA0+x(5))/PZ+(k%TOTALPATH-1)*L/EL%P%BETA0
       else
          X(6)=X(6)+k%TOTALPATH*L
       endif
    ENDIF
    CALL KILL(PZ)


  END SUBROUTINE KICKPATHP_HE_exact_nonsymp

  SUBROUTINE KICKPATHP_HE(EL,L,Z,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(HELICAL_DIPOLEP),INTENT(INOUT):: EL
    TYPE(REAL_8),INTENT(IN):: L,Z
    TYPE(REAL_8) PZ,PZ0,DPZ
    TYPE(INTERNAL_STATE),OPTIONAL :: K
    ! ETIENNE
    CALL ALLOC(PZ,PZ0,DPZ)
    IF(EL%P%EXACT) THEN
       if(k%TIME) then
          PZ=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2-X(2)**2-X(4)**2)
          PZ0=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
          DPZ=(X(2)**2+X(4)**2)/PZ/PZ0/(PZ+PZ0)   ! = (one/PZ-one/PZ0)
          X(1)=X(1)+L*X(2)*DPZ
          X(3)=X(3)+L*X(4)*DPZ

          X(6)=X(6)+L*(PZ0/PZ-(X(2)**2+X(4)**2)/PZ0**2/2.0_dp)*   &
               (1.0_dp/EL%P%BETA0+X(5))/PZ0 +(k%TOTALPATH-1)*L/EL%P%BETA0
       else
          PZ=SQRT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          PZ0=1.0_dp+X(5)
          DPZ=(X(2)**2+X(4)**2)/PZ/PZ0/(PZ+PZ0)   ! = (one/PZ-one/PZ0)
          X(1)=X(1)+L*X(2)*DPZ
          X(3)=X(3)+L*X(4)*DPZ
          X(6)=X(6)+L*(PZ0/PZ-(X(2)**2+X(4)**2)/PZ0**2/2.0_dp)+(k%TOTALPATH-1)*L
       endif
    ELSE
       if(k%TIME) then
          PZ0=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
          X(6)=X(6)+L*(1.0_dp/EL%P%BETA0+x(5))/PZ0+(k%TOTALPATH-1)*L/EL%P%BETA0
       else
          X(6)=X(6)+k%TOTALPATH*L
       endif
    ENDIF
    CALL KILL(PZ,PZ0,DPZ)


  END SUBROUTINE KICKPATHP_HE

  SUBROUTINE DRIFTR_HE(EL,L,Z,PLANE,X,k)
    IMPLICIT NONE
    TYPE(HELICAL_DIPOLE),INTENT(INOUT):: EL
    real(dp),INTENT(INOUT):: X(6)
    real(dp), INTENT(IN):: L,Z
    INTEGER, INTENT(IN)::PLANE
    real(dp) PZ,A(3),int_ax_dy,int_aY_dX
    TYPE(INTERNAL_STATE) K
    !DRIFT(EL,DH,Z,1,X,K)
    if(el%p%exact) return
    IF(PLANE==1) THEN
       CALL compute_f4(EL,X,Z,A=A,int_ax_dy=int_ax_dy)
       X(2)=X(2)-el%p%charge*A(1)
       X(4)=X(4)-el%p%charge*int_ax_dy
       if(k%TIME) then
          PZ=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%BETA0+x(5)**2)
          X(1)=X(1)+L*X(2)/pz
          X(6)=X(6)+((X(2)*X(2))/2.0_dp/pz**2)*(1.0_dp/EL%P%BETA0+x(5))*L/pz
       else
          X(1)=X(1)+L*X(2)/(1.0_dp+X(5))
          X(6)=X(6)+(L/(1.0_dp+X(5)))*(X(2)*X(2))/2.0_dp/(1.0_dp+X(5))
       endif
       CALL compute_f4(EL,X,Z,A=A,int_ax_dy=int_ax_dy)
       X(2)=X(2)+el%p%charge*A(1)
       X(4)=X(4)+el%p%charge*int_ax_dy
    ELSE
       CALL compute_f4(EL,X,Z,A=A,int_aY_dX=int_aY_dX)
       X(2)=X(2)-el%p%charge*int_aY_dX
       X(4)=X(4)-el%p%charge*A(2)
       if(k%TIME) then
          PZ=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%BETA0+x(5)**2)
          X(3)=X(3)+L*X(4)/pz
          X(6)=X(6)+((X(4)*X(4))/2.0_dp/pz**2)*(1.0_dp/EL%P%BETA0+x(5))*L/pz
       else
          X(3)=X(3)+L*X(4)/(1.0_dp+X(5))
          X(6)=X(6)+(L/(1.0_dp+X(5)))*(X(4)*X(4))/2.0_dp/(1.0_dp+X(5))
       endif
       CALL compute_f4(EL,X,Z,A=A,int_aY_dX=int_aY_dX)
       X(2)=X(2)+el%p%charge*int_aY_dX
       X(4)=X(4)+el%p%charge*A(2)
    ENDIF
  END SUBROUTINE DRIFTR_HE

  SUBROUTINE DRIFTP_HE(EL,L,Z,PLANE,X,k)
    IMPLICIT NONE
    TYPE(HELICAL_DIPOLEP),INTENT(INOUT):: EL
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8), INTENT(IN):: L,Z
    INTEGER, INTENT(IN)::PLANE
    TYPE(REAL_8) PZ,A(3),int_ax_dy,int_aY_dX
    TYPE(INTERNAL_STATE) K
    if(el%p%exact) return

    CALL ALLOC(PZ,int_ax_dy,int_aY_dX)
    CALL ALLOC(A,3)
    IF(PLANE==1) THEN

       CALL compute_f4(EL,X,Z,A=A,int_ax_dy=int_ax_dy)

       X(2)=X(2)-el%p%charge*A(1)
       X(4)=X(4)-el%p%charge*int_ax_dy

       if(k%TIME) then
          PZ=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%BETA0+x(5)**2)
          X(1)=X(1)+L*X(2)/pz
          X(6)=X(6)+((X(2)*X(2))/2.0_dp/pz**2)*(1.0_dp/EL%P%BETA0+x(5))*L/pz
       else
          X(1)=X(1)+L*X(2)/(1.0_dp+X(5))
          X(6)=X(6)+(L/(1.0_dp+X(5)))*(X(2)*X(2))/2.0_dp/(1.0_dp+X(5))
       endif
       CALL compute_f4(EL,X,Z,A=A,int_ax_dy=int_ax_dy)
       X(2)=X(2)+el%p%charge*A(1)
       X(4)=X(4)+el%p%charge*int_ax_dy
    ELSE
       CALL compute_f4(EL,X,Z,A=A,int_aY_dX=int_aY_dX)
       X(2)=X(2)-el%p%charge*int_aY_dX
       X(4)=X(4)-el%p%charge*A(2)
       if(k%TIME) then
          PZ=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%BETA0+x(5)**2)
          X(3)=X(3)+L*X(4)/pz
          X(6)=X(6)+((X(4)*X(4))/2.0_dp/pz**2)*(1.0_dp/EL%P%BETA0+x(5))*L/pz
       else
          X(3)=X(3)+L*X(4)/(1.0_dp+X(5))
          X(6)=X(6)+(L/(1.0_dp+X(5)))*(X(4)*X(4))/2.0_dp/(1.0_dp+X(5))
       endif
       CALL compute_f4(EL,X,Z,A=A,int_aY_dX=int_aY_dX)
       X(2)=X(2)+el%p%charge*int_aY_dX
       X(4)=X(4)+el%p%charge*A(2)
    ENDIF
    CALL KILL(PZ,int_ax_dy,int_aY_dX)
    CALL KILL(A,3)
  END SUBROUTINE DRIFTP_HE

!!!!   Enge function
  SUBROUTINE enge_f(EL,z0)
    IMPLICIT NONE
    type(enge), intent(inout) :: el
    real(dp), intent(inout) :: z0
    type(my_1D_taylor)z,dz
    integer i

    EL%F=0.0_dp
    z=z0
    dz=1.0_dp
    z%a(1)=1.0_dp

    do i=0,N_ENGE
       EL%F=EL%F+EL%A(I)*DZ
       dz=dz*(Z-EL%L/2.0_dp)/EL%D
    enddo
    EL%F=1.0_dp/(1.0_dp+EXP(EL%F))
  end subroutine enge_f

  SUBROUTINE ZEROr_enge(EL,I)
    IMPLICIT NONE
    TYPE(ENGE), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%D)) then
          deallocate(EL%D)
          deallocate(EL%A)
          deallocate(EL%NBESSEL)
          deallocate(EL%F)
       endif
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%D)
       NULLIFY(EL%NBESSEL)
       NULLIFY(EL%A)
       NULLIFY(EL%F)
    endif

  END SUBROUTINE ZEROr_enge

  SUBROUTINE ZEROP_enge(EL,I)
    IMPLICIT NONE
    TYPE(ENGEP), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !    integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%D)) then
          deallocate(EL%D)
          deallocate(EL%A)
          deallocate(EL%NBESSEL)
          deallocate(EL%F)
       endif
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%D)
       NULLIFY(EL%NBESSEL)
       NULLIFY(EL%A)
       NULLIFY(EL%F)
    endif

  END SUBROUTINE ZEROP_enge

  SUBROUTINE elliptical_b_r(st,sc,coord,bx,by)
    ! Tracking subroutine for elliptical lens
    ! A.Valishev (valishev@fnal.gov) October 19, 2010
    ! Modified by E. Forest for PTC
    !
    ! U(u,v)=(u*sqrt(u**2-1)+v*sqrt(1-v**2)*(-pi/2+acos(v))/(u**2-v**2)
    !st=lens strength
    ! sc=c
    ! b= bfield in x and y

    implicit none

    !global variables

    real(dp), intent(inout) ::  coord(6),bx,by
    real(dp), intent(in) :: st,sc

    real(dp) dd, u, v, dUu, dUv, dux, duy, dvx, dvy, x, y

    bx=0.0_dp
    by=0.0_dp
    IF(ABS(SC)<=eps) RETURN
    x = coord(1)/sc
    y =  coord(3)/sc
    u=0.5_dp*sqrt((x-1.0_dp)**2+y**2)+0.5_dp*sqrt((x+1.0_dp)**2+y**2)
    v=0.5_dp*sqrt((x+1.0_dp)**2+y**2)-0.5_dp*sqrt((x-1.0_dp)**2+y**2)
    if (u.eq.1.0_dp) then
       dd=0.0_dp
    else
       dd=u**2*log(u+sqrt(u*u-1.0_dp))/sqrt(u**2-1.0_dp)
    end if
    dUu=(u+log(u+sqrt(u*u-1.0_dp))*sqrt(u**2-1.0_dp)+dd)/(u**2-v**2) &
         -2.0_dp*u*(u*log(u+sqrt(u*u-1.0_dp))*sqrt(u**2-1.0_dp) &
         +v*(acos(v)-0.5_dp*pi)*sqrt(1.0_dp-v**2)) /(u**2-v**2)**2
    dUv=2.0_dp*v*(u*log(u+sqrt(u*u-1.0_dp))*sqrt(u**2-1.0_dp) &
         +v*(acos(v)-0.5_dp*pi)*sqrt(1.0_dp-v**2)) /(u**2-v**2)**2 &
         -(v-(acos(v)-0.5_dp*pi)*sqrt(1.0_dp-v**2)+v**2*(acos(v)-0.5_dp*pi)/sqrt(1.0_dp-v**2))&
         /(u**2-v**2)
    dux=0.5_dp*(x-1.0_dp)/sqrt((x-1.0_dp)**2+y**2) +0.5_dp*(x+1.0_dp)/sqrt((x+1.0_dp)**2+y**2)
    duy=0.5_dp*y/sqrt((x-1.0_dp)**2+y**2) +0.5_dp*y/sqrt((x+1.0_dp)**2+y**2)
    dvx=0.5_dp*(x+1.0_dp)/sqrt((x+1.0_dp)**2+y**2) -0.5_dp*(x-1.0_dp)/sqrt((x-1.0_dp)**2+y**2)
    dvy=0.5_dp*y/sqrt((x+1.0_dp)**2+y**2) -0.5_dp*y/sqrt((x-1.0_dp)**2+y**2)

    by=-st*(dUu*dux+dUv*dvx)/sc
    bx=st*(dUu*duy+dUv*dvy)/sc

  end SUBROUTINE elliptical_b_r

  SUBROUTINE elliptical_b_p(st,sc,coord,bx,by)
    ! Tracking subroutine for elliptical lens
    ! A.Valishev (valishev@fnal.gov) October 19, 2010
    ! Modified by E. Forest for PTC
    !
    ! U(u,v)=(u*sqrt(u**2-1)+v*sqrt(1-v**2)*(-pi/2+acos(v))/(u**2-v**2)
    !st=lens strength
    ! sc=c
    ! b= bfield in x and y

    implicit none

    !global variables

    type(real_8), intent(inout) :: coord(6),bx,by
    type(real_8), intent(in) :: st,sc
    type(real_8) dd,ac,sqv,u, v, dUu, dUv, dux, duy, dvx, dvy, x, y,dv,uv2,uv,sqb,sqbm
    integer i,n
    real(dp) xu,x1,x2

    bx=0.0_dp
    by=0.0_dp
    IF(ABS(SC)<=eps) RETURN

    call alloc(u, v, dUu, dUv, dux, duy, dvx, dvy, x, y)
    call alloc(dd,dv,uv,uv2,ac,sqv,sqb,sqbm)

    bx=st*2.0_dp/sc**2*coord(3)
    by=st*2.0_dp/sc**2*coord(1)

    x = coord(1)/sc
    y =  coord(3)/sc
    sqb=sqrt((x+1.0_dp)**2+y**2)
    sqbm=sqrt((x-1.0_dp)**2+y**2)

    u=0.5_dp*sqbm+0.5_dp*sqb
    v=0.5_dp*sqb-0.5_dp*sqbm
    xu=u
    if (xu<1.1_dp) then
       !if (valishev) then
       !write(6,*) " xu expanded", xu
       dUu=u-1.0_dp
       dUv=1.0_dp
       dv=0.0_dp
       !   do i=0,(nvalishev-1)/2
       do i=0,(size(val_del%a)-1)/2
          dv=val_del%a(i)*duv+dv
          duv=duv*dUu
          ! write(6,*) i, val_del%a(i)
       enddo
       dd=dv*u**2/sqrt(u+1.0_dp)
       dv=dv*sqrt(u+1.0_dp)*(u-1.0_dp)
    else
       ! write(6,*) " xu normal", xu
       dd=u**2*log(u+sqrt(u*u-1.0_dp))/sqrt(u**2-1.0_dp)
       dv=log(u+sqrt(u*u-1.0_dp))/sqrt(u-1.0_dp)
       dv=dv*sqrt(u+1.0_dp)*(u-1.0_dp)
    end if
    uv=(u**2-v**2)
    uv2=uv**2
    ac=acos(v)


    sqv=sqrt(1.0_dp-v**2)

    dUu=(u+dv+dd)/uv-2.0_dp*u*(u*dv+v*(ac-0.5_dp*pi)*sqv) /uv2
    dUv=2.0_dp*v*(u*dv+v*(ac-0.5_dp*pi)*sqv) /uv2
    dUv=dUv-(v-(ac-0.5_dp*pi)*sqv+v**2*(ac-0.5_dp*pi)/sqv)/uv

    dux=0.5_dp*(x-1.0_dp)/sqbm +0.5_dp*(x+1.0_dp)/sqb

    duy=0.5_dp*y/sqbm +0.5_dp*y/sqb
    dvx=0.5_dp*(x+1.0_dp)/sqb -0.5_dp*(x-1.0_dp)/sqbm
    dvy=0.5_dp*y/sqb -0.5_dp*y/sqbm

    by=-st*(dUu*dux+dUv*dvx)/sc
    bx=st*(dUu*duy+dUv*dvy)/sc

    !call print(by,10)
    !call print(bx,10)
    !goto 100

100 call kill(u, v, dUu, dUv, dux, duy, dvx, dvy, x, y)
    call kill(dd,dv,uv,uv2,ac,sqv,sqb,sqbm)


  end SUBROUTINE elliptical_b_p

 
END MODULE S_DEF_KIND
